From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.io!.POSTED.blaine.gmane.org!not-for-mail From: =?utf-8?Q?Miguel_=C3=81ngel_Arruga_Vivas?= Newsgroups: gmane.lisp.guile.devel Subject: [WIP: PATCH 2/2] uselocale Date: Tue, 13 Oct 2020 21:15:57 +0200 Message-ID: <875z7e0weq.fsf@gmail.com> References: <87h7qy0wlc.fsf@gmail.com> Mime-Version: 1.0 Content-Type: multipart/signed; boundary="==-=-="; micalg=pgp-sha512; protocol="application/pgp-signature" Injection-Info: ciao.gmane.io; posting-host="blaine.gmane.org:116.202.254.214"; logging-data="33881"; mail-complaints-to="usenet@ciao.gmane.io" User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/27.1 (gnu/linux) To: guile-devel@gnu.org Original-X-From: guile-devel-bounces+guile-devel=m.gmane-mx.org@gnu.org Tue Oct 13 21:17:54 2020 Return-path: Envelope-to: guile-devel@m.gmane-mx.org Original-Received: from lists.gnu.org ([209.51.188.17]) by ciao.gmane.io with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.92) (envelope-from ) id 1kSPo1-0008ii-Ro for guile-devel@m.gmane-mx.org; Tue, 13 Oct 2020 21:17:53 +0200 Original-Received: from localhost ([::1]:54626 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1kSPo0-0003ES-Rk for guile-devel@m.gmane-mx.org; Tue, 13 Oct 2020 15:17:52 -0400 Original-Received: from eggs.gnu.org ([2001:470:142:3::10]:36402) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1kSPnD-0003Au-6C for guile-devel@gnu.org; Tue, 13 Oct 2020 15:17:03 -0400 Original-Received: from mail-wm1-x336.google.com ([2a00:1450:4864:20::336]:37418) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1kSPnA-0007Mp-Fr for guile-devel@gnu.org; Tue, 13 Oct 2020 15:17:02 -0400 Original-Received: by mail-wm1-x336.google.com with SMTP id j136so907717wmj.2 for ; Tue, 13 Oct 2020 12:16:56 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=20161025; h=from:to:subject:references:date:in-reply-to:message-id:user-agent :mime-version; bh=M3GiFLJn4yERvHWSsKohHTX92VKjldSEAcZJluyppnE=; b=qWCS92/at6vQa3G6iFObUZsMYplH3xhdnMh1qmR+yB4F7Mm9UgE4mOClOosEdTb/TL 02P9J5uJUozlhklrPLQM7n6rolCtshgROrSd05edeBaZQHKqhoMs5kW8aqAe/Yk/X5rk HJfIFdx5pZWOoVikzyTOCEDgk5MW3ZnTjY5JXWym3cVpc2sKlquIpHh/q5udvbAzxYMH 4+w51I6sd+Pw45L3lG/9vg5QeQPwaM0thVI3FDLn3KpVVr3gFA931ib1q642gUUHl8lT uvm2zrnWdZdmdL4Z6rSii4tdBGLThtP6V7eyZw2JsBWcwb/h1OMPEfAOs60cewInBWY+ TTnw== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20161025; h=x-gm-message-state:from:to:subject:references:date:in-reply-to :message-id:user-agent:mime-version; bh=M3GiFLJn4yERvHWSsKohHTX92VKjldSEAcZJluyppnE=; b=NYwUjcetWNB4mr2QfQNzsAjAZAVWjMdnrgOShQWBgupFfm2zjux7AhIb3U+UpyF0G+ Im7THcWgWTbnJp1khdEKcY7gcqQ0JCpbdgL3fcg/v3byZ6T5GP1EdXW3o80IhDLKwe0M qwk47irl4M1WujykM51qpJk942llipNnpV3lghMSXYS4ZTMUcmI7d54pVgEbwwZWtwKX EUFLgWrjVTvXQLftDxKGX3egMJ1LYaE65FTzk4pBq5cWKnOZriPfeNBO1M971jTttvUD nFSiEy79mqCTdFbAs/6OnprRL7aEAEsJl315lGxQPJlUbPuLLAeF2rTwWO04S7Vd4qBu sxfg== X-Gm-Message-State: AOAM533Zb2Z3/idpmk4Azsn8cHGqLsUKpqPJ7MpKqdUkPGxeD3QoAu0o OSmPmCFxNjjqvO2TsP6iw44Zh7GJ+l7rBg== X-Google-Smtp-Source: ABdhPJycDgfBfMVbm74+Z6fTEO/0JKawVy8OCDw0HkQ0Sfuuvz8hZLbbQ8Mf5/HfvnDQwZ8b72EluA== X-Received: by 2002:a1c:7f97:: with SMTP id a145mr1347991wmd.160.1602616614055; Tue, 13 Oct 2020 12:16:54 -0700 (PDT) Original-Received: from unfall (218.139.134.37.dynamic.jazztel.es. [37.134.139.218]) by smtp.gmail.com with ESMTPSA id 1sm756620wre.61.2020.10.13.12.16.52 for (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Tue, 13 Oct 2020 12:16:53 -0700 (PDT) In-Reply-To: <87h7qy0wlc.fsf@gmail.com> ("Miguel =?utf-8?Q?=C3=81ngel?= Arruga Vivas"'s message of "Tue, 13 Oct 2020 21:11:59 +0200") Received-SPF: pass client-ip=2a00:1450:4864:20::336; envelope-from=rosen644835@gmail.com; helo=mail-wm1-x336.google.com X-detected-operating-system: by eggs.gnu.org: No matching host in p0f cache. That's all we know. X-Spam_score_int: -17 X-Spam_score: -1.8 X-Spam_bar: - X-Spam_report: (-1.8 / 5.0 requ) BAYES_00=-1.9, DKIM_SIGNED=0.1, DKIM_VALID=-0.1, DKIM_VALID_AU=-0.1, DKIM_VALID_EF=-0.1, FREEMAIL_ENVFROM_END_DIGIT=0.25, FREEMAIL_FROM=0.001, RCVD_IN_DNSWL_NONE=-0.0001, SPF_HELO_NONE=0.001, SPF_PASS=-0.001 autolearn=ham autolearn_force=no X-Spam_action: no action X-BeenThere: guile-devel@gnu.org X-Mailman-Version: 2.1.23 Precedence: list List-Id: "Developers list for Guile, the GNU extensibility library" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guile-devel-bounces+guile-devel=m.gmane-mx.org@gnu.org Original-Sender: "guile-devel" Xref: news.gmane.io gmane.lisp.guile.devel:20593 Archived-At: --==-=-= Content-Type: multipart/mixed; boundary="=-=-=" --=-=-= Content-Type: text/plain This one is the uselocale code. --=-=-= Content-Type: text/x-patch; charset=utf-8 Content-Disposition: attachment; filename=0002-Add-support-for-thread-local-locale-when-available.patch Content-Transfer-Encoding: quoted-printable Content-Description: 0002-uselocale.patch From=2055cdc6b3ac8642be524b1b1b8b4ee29f14b64b10 Mon Sep 17 00:00:00 2001 From: =3D?UTF-8?q?Miguel=3D20=3DC3=3D81ngel=3D20Arruga=3D20Vivas?=3D Date: Mon, 12 Oct 2020 14:02:40 +0200 Subject: [PATCH 2/2] Add support for thread-local locale when available. * libguile/i18n.c (scm_uselocale): New interface for uselocale. (internal_uselocale): New internal function. (scm_with_thread_locale): New function. (scm_init_i18n): Add feature "uselocale". Remove comment about LC_GLOBAL_LOCALE, as it is not exposed directly to Scheme code. * libguile/i18n.h (scm_uselocale, scm_with_thread_locale): New prototypes. * module/ice-9/i18n.scm (with-thread-locale): New macro. * test-suite/tests/i18n.test: Add tests for uselocale feature. * test-suite/tests/time.test: Likewise. These tests were adapted from previous examples. =2D-- libguile/i18n.c | 130 ++++++++++++++++++++++++++++++++++++- libguile/i18n.h | 3 + module/ice-9/i18n.scm | 12 ++++ test-suite/tests/i18n.test | 49 ++++++++++++++ test-suite/tests/time.test | 37 ++++++++++- 5 files changed, 225 insertions(+), 6 deletions(-) diff --git a/libguile/i18n.c b/libguile/i18n.c index 7b80e7427..b8a14741e 100644 =2D-- a/libguile/i18n.c +++ b/libguile/i18n.c @@ -33,6 +33,7 @@ #include "chars.h" #include "dynwind.h" #include "extensions.h" +#include "eval.h" /* for `scm_call_0' */ #include "feature.h" #include "gsubr.h" #include "list.h" @@ -1886,6 +1887,126 @@ define_langinfo_items (void) #undef DEFINE_NLITEM_CONSTANT } =20 + +/* Thread-specific locale. */ + +#ifdef USE_GNU_LOCALE_API + +SCM_DEFINE (scm_uselocale, "uselocale", 0, 1, 0, (SCM locale), + "This procedure checks and/or modifies the locale used\n" + "by the current thread @emph{without} modifying the\n" + "output port status.\n\n" + "It's responsibility of the user to not rely on the\n" + "globally accessible input and output ports, which usually\n" + "usually is a bad idea in a multi-threaded scenario.\n\n" + "The behaviour is determined by @var{locale}:\n\n" + "@table @r\n" + "@item @var{locale} is not provided\n" + "Only retrieve the locale used by the current thread.\n" + "@item @var{locale} is @code{#f}\n" + "Remove the locale installed in the current thread, if\n" + "there was one installed, and use the global locale.\n" + "@item @var{locale} is a valid @code{} object.\n" + "Install the provided locale to be used by the current\n" + "thread.\n" + "@end table\n\n" + "This procedure return two values:\n\n" + "@enumerate\n" + "@item\n" + "A boolean indicating whether thread has a thread-specific\n" + "locale installed or not.\n" + "@item\n" + "The locale in use by the thread before the call.\n" + "@end enumerate") +#define FUNC_NAME s_scm_uselocale +{ + SCM is_thr_local, ret; + scm_t_locale c_locale, current; + + scm_dynwind_begin (0); + + if (SCM_UNBNDP (locale)) + c_locale =3D (scm_t_locale) 0; + else if (scm_is_false (locale)) + c_locale =3D LC_GLOBAL_LOCALE; + else + SCM_VALIDATE_LOCALE_COPY(1, locale, c_locale); + + current =3D uselocale (c_locale); + + if (current =3D=3D (scm_t_locale) 0) + SCM_SYSERROR; + + if (current =3D=3D LC_GLOBAL_LOCALE) + is_thr_local =3D SCM_BOOL_F; + else + is_thr_local =3D SCM_BOOL_T; + + current =3D duplocale (current); + + if (current =3D=3D (scm_t_locale) 0) + SCM_SYSERROR; + + scm_dynwind_unwind_handler ((void (*)(void *))freelocale, current, 0); + + SCM_NEWSMOB (ret, scm_tc16_locale_smob_type, current); + + scm_dynwind_end (); + return scm_values_2 (is_thr_local, ret); +} +#undef FUNC_NAME + +static void +internal_uselocale (void *locale) +#define FUNC_NAME "" +{ + if (uselocale ((scm_t_locale) locale) =3D=3D (scm_t_locale) 0) + SCM_SYSERROR; +} +#undef FUNC_NAME + +SCM_DEFINE(scm_with_thread_locale, "%with-thread-locale", + 2, 0, 0, + (SCM locale, SCM thunk), + "Execute @var{thunk} with the thread-specific locale\n" + "set to @var{locale}.\n\n" + "It's behaviour is equivalent to the following Scheme\n" + "code:\n\n" + "@example\n" + "(define (%with-thread-locale locale thunk)\n" + " (let (at-exit)\n" + " (define (in-guard)\n" + " (define-values (is-tl locale) (uselocale locale))\n" + " (set! at-exit (and is-tl locale)))\n" + " (define (out-guard)\n" + " (uselocale at-exit))\n" + " (dynamic-wind in-guard thunk out-guard)))\n" + "@end example") +#define FUNC_NAME s_scm_with_thread_locale +{ + SCM ret; + scm_t_locale c_locale, c_current; + + scm_dynwind_begin (0); + + SCM_VALIDATE_LOCALE_COPY(1, locale, c_locale); + + c_current =3D uselocale (c_locale); + if (c_current =3D=3D (scm_t_locale) 0) + SCM_SYSERROR; + + scm_dynwind_rewind_handler (internal_uselocale, c_locale, 0); + scm_dynwind_unwind_handler (internal_uselocale, c_current, + SCM_F_WIND_EXPLICITLY); + + ret =3D scm_call_0 (thunk); + scm_dynwind_end (); + return ret; +} +#undef FUNC_NAME + +#endif /* USE_GNU_LOCALE_API */ + void scm_init_i18n () @@ -1895,12 +2016,15 @@ scm_init_i18n () scm_add_feature ("nl-langinfo"); define_langinfo_items (); =20 +#ifdef USE_GNU_LOCALE_API + scm_add_feature ("uselocale"); +#endif + #include "i18n.x" =20 /* Initialize the global locale object with a special `locale' SMOB. */ =2D /* XXX: We don't define it as `LC_GLOBAL_LOCALE' because of bugs as of =2D glibc <=3D 2.11 not (yet) worked around by Gnulib. See =2D http://sourceware.org/bugzilla/show_bug.cgi?id=3D11009 for details.= */ + /* LC_GLOBAL_LOCALE is only exposed indirectly through uselocale + interface when this is available. */ SCM_NEWSMOB (global_locale_smob, scm_tc16_locale_smob_type, NULL); SCM_VARIABLE_SET (scm_global_locale, global_locale_smob); } diff --git a/libguile/i18n.h b/libguile/i18n.h index 8ce1ce8e6..0538453ab 100644 =2D-- a/libguile/i18n.h +++ b/libguile/i18n.h @@ -46,6 +46,9 @@ SCM_API SCM scm_locale_string_to_inexact (SCM str, SCM lo= cale); =20 SCM_INTERNAL SCM scm_nl_langinfo (SCM item, SCM locale); =20 +SCM_API SCM scm_uselocale (SCM locale); +SCM_API SCM scm_with_thread_locale (SCM locale, SCM thunk); + SCM_INTERNAL void scm_init_i18n (void); SCM_INTERNAL void scm_bootstrap_i18n (void); =20 diff --git a/module/ice-9/i18n.scm b/module/ice-9/i18n.scm index 319d5a23c..8eb931acf 100644 =2D-- a/module/ice-9/i18n.scm +++ b/module/ice-9/i18n.scm @@ -35,6 +35,10 @@ make-locale locale? %global-locale =20 + ;; thread-specific locale + uselocale + with-thread-locale + ;; text collation string-locale? string-locale-ci? string-locale-ci=3D? @@ -91,6 +95,14 @@ (load-extension (string-append "libguile-" (effective-version)) "scm_init_i18n")) =20 + +;; Define the macro with-thread-locale when the implementation is +;; available. +(define-syntax with-thread-locale + (syntax-rules () + ((_ locale exp exp* ...) + (%with-thread-locale locale (lambda () exp exp* ...))))) + ;;; ;;; Charset/encoding. diff --git a/test-suite/tests/i18n.test b/test-suite/tests/i18n.test index 427aef4f5..f76af4ea6 100644 =2D-- a/test-suite/tests/i18n.test +++ b/test-suite/tests/i18n.test @@ -20,6 +20,7 @@ =20 (define-module (test-suite i18n) #:use-module (ice-9 i18n) + #:use-module (ice-9 threads) #:use-module (ice-9 format) #:use-module (srfi srfi-1) #:use-module (test-suite lib)) @@ -726,3 +727,51 @@ (lambda () (let ((fr (make-locale LC_ALL %french-locale-name))) (monetary-amount->locale-string .00003 #t fr))))))) + +;;; +;;; Thread local facilities. +;;; + +(with-test-prefix "uselocale" + (define (check-provided features) + (for-each (lambda (feature) + (or (provided? feature) (throw 'unsupported))) + features)) + + (pass-if "main thread use global locale" + (check-provided '(uselocale)) + + (not (uselocale))) + + (pass-if "fresh thread use global locale" + (check-provided '(uselocale threads)) + + (join-thread (begin-thread (not (uselocale))))) + + (pass-if "fresh thread install locale" + (check-provided '(uselocale threads)) + (unless %c-locale (throw 'unresolved)) + + (join-thread + (begin-thread + (uselocale %c-locale) + (uselocale)))) + + (pass-if "clean thread locale" + (check-provided '(uselocale threads)) + (unless %c-locale (throw 'unresolved)) + (join-thread + (begin-thread + (uselocale %c-locale) + (uselocale #f) + (not (uselocale))))) + + (with-test-prefix "with-thread-locale" + + (pass-if "locale" + (check-provided '(uselocale threads)) + (unless %c-locale (throw 'unresolved)) + + (join-thread + (begin-thread + (with-thread-locale %c-locale (uselocale))))))) diff --git a/test-suite/tests/time.test b/test-suite/tests/time.test index 0291b6bdf..0758e3940 100644 =2D-- a/test-suite/tests/time.test +++ b/test-suite/tests/time.test @@ -19,7 +19,8 @@ =20 (define-module (test-suite test-time) #:use-module (test-suite lib) =2D #:use-module (ice-9 threads)) + #:use-module (ice-9 threads) + #:use-module (ice-9 i18n)) =20 ;;; ;;; gmtime @@ -240,7 +241,22 @@ (pass-if-equal "strftime fr_FR.iso88591" ; " 1 f=C3=A9vrier 1970" (with-locale "fr_FR.iso88591" =2D (strftime "%e %B %Y" (gmtime (* 31 24 3600))))))) + (strftime "%e %B %Y" (gmtime (* 31 24 3600)))))) + + (with-test-prefix "uselocale" + (define (strftime-tl loc fmt tm) + (unless (and (provided? 'threads) (provided? 'uselocale)) + (throw 'unsupported)) + (join-thread + (begin-thread + (with-thread-locale (make-locale LC_ALL loc) (strftime fmt tm))))) + + (pass-if-equal "fr_FR.utf8" + " 1 f=C3=A9vrier 1970" + (strftime-tl "fr_FR.utf8" "%e %B %Y" (gmtime (* 31 24 3600)))) + (pass-if-equal "fr_FR.iso88591" + " 1 f=C3=A9vrier 1970" + (strftime-tl "fr_FR.iso88591" "%e %B %Y" (gmtime (* 31 24 3600)))))) =20 ;;; ;;; strptime @@ -295,4 +311,19 @@ (putenv "TZ=3DEST+5") (tzset) (let ((tm (car (strptime "%s" "86400")))) =2D (eqv? (* 5 3600) (tm:gmtoff tm)))))) + (eqv? (* 5 3600) (tm:gmtoff tm))))) + + (with-test-prefix "uselocale" + (define (strptime-tl loc fmt str) + (unless (and (provided? 'threads) (provided? 'uselocale)) + (throw 'unsupported)) + (join-thread + (begin-thread + (with-thread-locale (make-locale LC_ALL loc) + (let ((tm (car (strptime fmt str)))) + (list (tm:mday tm) + (+ 1 (tm:mon tm)) + (+ 1900 (tm:year tm)))))))) + (pass-if-equal "strftime fr_FR.utf8" + '(1 2 1999) + (strptime-tl "fr_FR.utf8" "%e %B %Y" " 1 f=C3=A9vrier 1999")))) =2D-=20 2.28.0 --=-=-=-- --==-=-= Content-Type: application/pgp-signature; name="signature.asc" -----BEGIN PGP SIGNATURE----- iQGzBAEBCgAdFiEEiIeExBRZrMuD5+hMY0xuiXn6vsIFAl+F/O0ACgkQY0xuiXn6 vsKvjgv/WaRwDxAQrj/imi3FLDLEzbOqLJ/Jejgw5t+Vgf4dBy3/1RD3a4961v+9 ULzbgm+wcqPazX/Hlz1hYeUlWKHTyJ75T+tFxlRROVlhOEpNMC2TMFp/V/M2O77A HHgHM48cAPK4OkpOs1a4I19FVjVu9lR22isVyBjN0flDriqp0RzMRaQAGkMaSlp8 GeNOR1aPwyDmwoC/DAipvshIEu+VzS0DtBYN6djIeH1+M4a+mwYiRMD/eZv86zjR xUuAI1BCJ/wxT9o/RK09vZldIDms8PL530nOZQkt/rq2eKmXjsLXZcyN1p+iqGFY hYM53a8Afq2Kty13rv7Wudj0GbFSOk6nG30tckgthy+6W/OhRh5/Dbet9OjCS3jx 8MsW8hI59ovMn6ZCHfa0f0bkrvjDiNeVUC6EKDU/Q9dLsULumaa/2r9KOtRovoix DBqp7H4FNjPXrJB7Bhf6DvesZIKT8wGZTjGkUJFRQuqsugEwoWdHKjRT45U+GaDA egCRXPcT =p/uf -----END PGP SIGNATURE----- --==-=-=--