/* See L<perlguts/"The Perl API"> for detailed notes on
* PERL_IMPLICIT_CONTEXT and PERL_IMPLICIT_SYS */
-/* Note that from here --> to <-- the same logic is
+/* XXX NOTE that from here --> to <-- the same logic is
* repeated in makedef.pl, so be certain to update
* both places when editing. */
#endif
/* Use the reentrant APIs like localtime_r and getpwent_r */
-/* Win32 has naturally threadsafe libraries, no need to use any _r variants. */
+/* Win32 has naturally threadsafe libraries, no need to use any _r variants.
+ * XXX KEEP makedef.pl copy of this code in sync */
#if defined(USE_ITHREADS) && !defined(USE_REENTRANT_API) && !defined(NETWARE) && !defined(WIN32)
# define USE_REENTRANT_API
#endif
# undef PERL_TRACK_MEMPOOL
#endif
+#ifdef DEBUGGING
+# define dTHX_DEBUGGING dTHX
+#else
+# define dTHX_DEBUGGING dNOOP
+#endif
+
#define STATIC static
#ifndef PERL_CORE
# if !defined(NO_LOCALE_TIME) && defined(LC_TIME)
# define USE_LOCALE_TIME
# endif
+# if !defined(NO_LOCALE_ADDRESS) && defined(LC_ADDRESS)
+# define USE_LOCALE_ADDRESS
+# endif
+# if !defined(NO_LOCALE_IDENTIFICATION) && defined(LC_IDENTIFICATION)
+# define USE_LOCALE_IDENTIFICATION
+# endif
+# if !defined(NO_LOCALE_MEASUREMENT) && defined(LC_MEASUREMENT)
+# define USE_LOCALE_MEASUREMENT
+# endif
+# if !defined(NO_LOCALE_PAPER) && defined(LC_PAPER)
+# define USE_LOCALE_PAPER
+# endif
+# if !defined(NO_LOCALE_TELEPHONE) && defined(LC_TELEPHONE)
+# define USE_LOCALE_TELEPHONE
+# endif
#endif /* !NO_LOCALE && HAS_SETLOCALE */
+#ifdef USE_LOCALE /* These locale things are all subject to change */
+# if defined(HAS_NEWLOCALE) \
+ && defined(LC_ALL_MASK) \
+ && defined(HAS_FREELOCALE) \
+ && defined(HAS_USELOCALE) \
+ && ! defined(NO_POSIX_2008_LOCALE)
+
+ /* For simplicity, the code is written to assume that any platform advanced
+ * enough to have the Posix 2008 locale functions has LC_ALL. The test
+ * above makes sure that assumption is valid */
+
+# define HAS_POSIX_2008_LOCALE
+# endif
+# if defined(USE_ITHREADS) \
+ && ( defined(HAS_POSIX_2008_LOCALE) \
+ || (defined(WIN32) && defined(_MSC_VER) && _MSC_VER >= 1400)) \
+ && ! defined(NO_THREAD_SAFE_LOCALE)
+# define USE_THREAD_SAFE_LOCALE
+# ifdef HAS_POSIX_2008_LOCALE
+# define USE_POSIX_2008_LOCALE
+# endif
+# endif
+#endif
+
+/* Microsoft documentation reads in the change log for VS 2015:
+ * "The localeconv function declared in locale.h now works correctly when
+ * per-thread locale is enabled. In previous versions of the library, this
+ * function would return the lconv data for the global locale, not the
+ * thread's locale."
+ */
+#if defined(WIN32) && defined(USE_THREAD_SAFE_LOCALE) && _MSC_VER < 1900
+# define TS_W32_BROKEN_LOCALECONV
+#endif
+
#include <setjmp.h>
#ifdef I_SYS_PARAM
XREF,
XSTATE,
XBLOCK,
- XATTRBLOCK,
- XATTRTERM,
+ XATTRBLOCK, /* next token should be an attribute or block */
+ XATTRTERM, /* next token should be an attribute, or block in a term */
XTERMBLOCK,
XBLOCKTERM,
XPOSTDEREF,
# define KEYWORD_PLUGIN_MUTEX_TERM NOOP
#endif
-#ifdef USE_LOCALE
-/* These locale things are all subject to change */
+#ifdef USE_LOCALE /* These locale things are all subject to change */
+ /* Returns TRUE if the plain locale pragma without a parameter is in effect.
+ * */
+# define IN_LOCALE_RUNTIME (PL_curcop \
+ && CopHINTS_get(PL_curcop) & HINT_LOCALE)
-# if defined(HAS_NEWLOCALE) \
- && defined(LC_ALL_MASK) \
- && defined(HAS_FREELOCALE) \
- && defined(HAS_USELOCALE) \
- && ! defined(NO_POSIX_2008_LOCALE)
+ /* Returns TRUE if either form of the locale pragma is in effect */
+# define IN_SOME_LOCALE_FORM_RUNTIME \
+ cBOOL(CopHINTS_get(PL_curcop) & (HINT_LOCALE|HINT_LOCALE_PARTIAL))
- /* The code is written for simplicity to assume that any platform advanced
- * enough to have the Posix 2008 locale functions has LC_ALL. The test
- * above makes sure that assumption is valid */
+# define IN_LOCALE_COMPILETIME cBOOL(PL_hints & HINT_LOCALE)
+# define IN_SOME_LOCALE_FORM_COMPILETIME \
+ cBOOL(PL_hints & (HINT_LOCALE|HINT_LOCALE_PARTIAL))
-# define HAS_POSIX_2008_LOCALE
-# endif
+# define IN_LOCALE \
+ (IN_PERL_COMPILETIME ? IN_LOCALE_COMPILETIME : IN_LOCALE_RUNTIME)
+# define IN_SOME_LOCALE_FORM \
+ (IN_PERL_COMPILETIME ? IN_SOME_LOCALE_FORM_COMPILETIME \
+ : IN_SOME_LOCALE_FORM_RUNTIME)
-/* We create a C locale object unconditionally if we have the functions to do
- * so; hence must destroy it unconditionally at the end */
-# ifndef HAS_POSIX_2008_LOCALE
-# define _LOCALE_TERM_POSIX_2008 NOOP
-# else
-# define _LOCALE_TERM_POSIX_2008 \
- STMT_START { \
- if (PL_C_locale_obj) { \
- /* Make sure we aren't using the locale \
- * space we are about to free */ \
- uselocale(LC_GLOBAL_LOCALE); \
- freelocale(PL_C_locale_obj); \
- PL_C_locale_obj = (locale_t) NULL; \
- } \
- } STMT_END
-# endif
+# define IN_LC_ALL_COMPILETIME IN_LOCALE_COMPILETIME
+# define IN_LC_ALL_RUNTIME IN_LOCALE_RUNTIME
-# ifndef USE_ITHREADS
-# define LOCALE_INIT
-# define LOCALE_LOCK
-# define LOCALE_UNLOCK
-# define LOCALE_TERM STMT_START { _LOCALE_TERM_POSIX_2008; } STMT_END
-# else /* Below is do use threads */
-# define LOCALE_INIT MUTEX_INIT(&PL_locale_mutex)
-# define LOCALE_LOCK MUTEX_LOCK(&PL_locale_mutex)
-# define LOCALE_UNLOCK MUTEX_UNLOCK(&PL_locale_mutex)
-# define LOCALE_TERM \
- STMT_START { \
- MUTEX_DESTROY(&PL_locale_mutex); \
- _LOCALE_TERM_POSIX_2008; \
- } STMT_END
-# ifdef HAS_POSIX_2008_LOCALE
-# define USE_POSIX_2008_LOCALE
-# define USE_THREAD_SAFE_LOCALE
-# endif
-# endif
+# define IN_LC_PARTIAL_COMPILETIME cBOOL(PL_hints & HINT_LOCALE_PARTIAL)
+# define IN_LC_PARTIAL_RUNTIME \
+ (PL_curcop && CopHINTS_get(PL_curcop) & HINT_LOCALE_PARTIAL)
-/* Returns TRUE if the plain locale pragma without a parameter is in effect
- */
-# define IN_LOCALE_RUNTIME (PL_curcop \
- && CopHINTS_get(PL_curcop) & HINT_LOCALE)
-
-/* Returns TRUE if either form of the locale pragma is in effect */
-# define IN_SOME_LOCALE_FORM_RUNTIME \
- cBOOL(CopHINTS_get(PL_curcop) & (HINT_LOCALE|HINT_LOCALE_PARTIAL))
-
-# define IN_LOCALE_COMPILETIME cBOOL(PL_hints & HINT_LOCALE)
-# define IN_SOME_LOCALE_FORM_COMPILETIME \
- cBOOL(PL_hints & (HINT_LOCALE|HINT_LOCALE_PARTIAL))
-
-# define IN_LOCALE \
- (IN_PERL_COMPILETIME ? IN_LOCALE_COMPILETIME : IN_LOCALE_RUNTIME)
-# define IN_SOME_LOCALE_FORM \
- (IN_PERL_COMPILETIME ? IN_SOME_LOCALE_FORM_COMPILETIME \
- : IN_SOME_LOCALE_FORM_RUNTIME)
-
-# define IN_LC_ALL_COMPILETIME IN_LOCALE_COMPILETIME
-# define IN_LC_ALL_RUNTIME IN_LOCALE_RUNTIME
-
-# define IN_LC_PARTIAL_COMPILETIME cBOOL(PL_hints & HINT_LOCALE_PARTIAL)
-# define IN_LC_PARTIAL_RUNTIME \
- (PL_curcop && CopHINTS_get(PL_curcop) & HINT_LOCALE_PARTIAL)
-
-# define IN_LC_COMPILETIME(category) \
- (IN_LC_ALL_COMPILETIME || (IN_LC_PARTIAL_COMPILETIME \
- && Perl__is_in_locale_category(aTHX_ TRUE, (category))))
-# define IN_LC_RUNTIME(category) \
- (IN_LC_ALL_RUNTIME || (IN_LC_PARTIAL_RUNTIME \
- && Perl__is_in_locale_category(aTHX_ FALSE, (category))))
-# define IN_LC(category) \
+# define IN_LC_COMPILETIME(category) \
+ ( IN_LC_ALL_COMPILETIME \
+ || ( IN_LC_PARTIAL_COMPILETIME \
+ && Perl__is_in_locale_category(aTHX_ TRUE, (category))))
+# define IN_LC_RUNTIME(category) \
+ (IN_LC_ALL_RUNTIME || (IN_LC_PARTIAL_RUNTIME \
+ && Perl__is_in_locale_category(aTHX_ FALSE, (category))))
+# define IN_LC(category) \
(IN_LC_COMPILETIME(category) || IN_LC_RUNTIME(category))
-# if defined (PERL_CORE) || defined (PERL_IN_XSUB_RE)
+# if defined (PERL_CORE) || defined (PERL_IN_XSUB_RE)
- /* This internal macro should be called from places that operate under
- * locale rules. It there is a problem with the current locale that
- * hasn't been raised yet, it will output a warning this time. Because
- * this will so rarely be true, there is no point to optimize for
- * time; instead it makes sense to minimize space used and do all the
- * work in the rarely called function */
-# ifdef USE_LOCALE_CTYPE
-# define _CHECK_AND_WARN_PROBLEMATIC_LOCALE \
+ /* This internal macro should be called from places that operate under
+ * locale rules. It there is a problem with the current locale that
+ * hasn't been raised yet, it will output a warning this time. Because
+ * this will so rarely be true, there is no point to optimize for time;
+ * instead it makes sense to minimize space used and do all the work in
+ * the rarely called function */
+# ifdef USE_LOCALE_CTYPE
+# define _CHECK_AND_WARN_PROBLEMATIC_LOCALE \
STMT_START { \
if (UNLIKELY(PL_warn_locale)) { \
Perl__warn_problematic_locale(); \
} \
} STMT_END
-# else
-# define _CHECK_AND_WARN_PROBLEMATIC_LOCALE
-# endif
+# else
+# define _CHECK_AND_WARN_PROBLEMATIC_LOCALE
+# endif
- /* These two internal macros are called when a warning should be raised,
- * and will do so if enabled. The first takes a single code point
- * argument; the 2nd, is a pointer to the first byte of the UTF-8 encoded
- * string, and an end position which it won't try to read past */
-# define _CHECK_AND_OUTPUT_WIDE_LOCALE_CP_MSG(cp) \
+ /* These two internal macros are called when a warning should be raised,
+ * and will do so if enabled. The first takes a single code point
+ * argument; the 2nd, is a pointer to the first byte of the UTF-8 encoded
+ * string, and an end position which it won't try to read past */
+# define _CHECK_AND_OUTPUT_WIDE_LOCALE_CP_MSG(cp) \
STMT_START { \
if (! PL_in_utf8_CTYPE_locale && ckWARN(WARN_LOCALE)) { \
Perl_warner(aTHX_ packWARN(WARN_LOCALE), \
} \
} STMT_END
-# define _CHECK_AND_OUTPUT_WIDE_LOCALE_UTF8_MSG(s, send) \
+# define _CHECK_AND_OUTPUT_WIDE_LOCALE_UTF8_MSG(s, send) \
STMT_START { /* Check if to warn before doing the conversion work */\
if (! PL_in_utf8_CTYPE_locale && ckWARN(WARN_LOCALE)) { \
UV cp = utf8_to_uvchr_buf((U8 *) s, (U8 *) send, NULL); \
} \
} STMT_END
-# endif /* PERL_CORE or PERL_IN_XSUB_RE */
+# endif /* PERL_CORE or PERL_IN_XSUB_RE */
#else /* No locale usage */
-# define LOCALE_INIT
-# define LOCALE_TERM
-# define LOCALE_LOCK
-# define LOCALE_UNLOCK
-# define IN_LOCALE_RUNTIME 0
-# define IN_SOME_LOCALE_FORM_RUNTIME 0
-# define IN_LOCALE_COMPILETIME 0
-# define IN_SOME_LOCALE_FORM_COMPILETIME 0
-# define IN_LOCALE 0
-# define IN_SOME_LOCALE_FORM 0
-# define IN_LC_ALL_COMPILETIME 0
-# define IN_LC_ALL_RUNTIME 0
-# define IN_LC_PARTIAL_COMPILETIME 0
-# define IN_LC_PARTIAL_RUNTIME 0
-# define IN_LC_COMPILETIME(category) 0
-# define IN_LC_RUNTIME(category) 0
-# define IN_LC(category) 0
-
-# define _CHECK_AND_WARN_PROBLEMATIC_LOCALE
-# define _CHECK_AND_OUTPUT_WIDE_LOCALE_CP_MSG(a)
-# define _CHECK_AND_OUTPUT_WIDE_LOCALE_UTF8_MSG(a,b)
+# define IN_LOCALE_RUNTIME 0
+# define IN_SOME_LOCALE_FORM_RUNTIME 0
+# define IN_LOCALE_COMPILETIME 0
+# define IN_SOME_LOCALE_FORM_COMPILETIME 0
+# define IN_LOCALE 0
+# define IN_SOME_LOCALE_FORM 0
+# define IN_LC_ALL_COMPILETIME 0
+# define IN_LC_ALL_RUNTIME 0
+# define IN_LC_PARTIAL_COMPILETIME 0
+# define IN_LC_PARTIAL_RUNTIME 0
+# define IN_LC_COMPILETIME(category) 0
+# define IN_LC_RUNTIME(category) 0
+# define IN_LC(category) 0
+#endif
+
+
+/* Locale/thread synchronization macros. These aren't needed if using
+ * thread-safe locale operations, except if something is broken */
+#if defined(USE_LOCALE) \
+ && defined(USE_ITHREADS) \
+ && (! defined(USE_THREAD_SAFE_LOCALE) || defined(TS_W32_BROKEN_LOCALECONV))
+
+/* We have a locale object holding the 'C' locale for Posix 2008 */
+#ifndef USE_POSIX_2008_LOCALE
+# define _LOCALE_TERM_POSIX_2008 NOOP
+# else
+# define _LOCALE_TERM_POSIX_2008 \
+ STMT_START { \
+ if (PL_C_locale_obj) { \
+ /* Make sure we aren't using the locale \
+ * space we are about to free */ \
+ uselocale(LC_GLOBAL_LOCALE); \
+ freelocale(PL_C_locale_obj); \
+ PL_C_locale_obj = (locale_t) NULL; \
+ } \
+ } STMT_END
+# endif
+
+/* This is used as a generic lock for locale operations. For example this is
+ * used when calling nl_langinfo() so that another thread won't zap the
+ * contents of its buffer before it gets saved; and it's called when changing
+ * the locale of LC_MESSAGES. On some systems the latter can cause the
+ * nl_langinfo buffer to be zapped under a race condition.
+ *
+ * If combined with LC_NUMERIC_LOCK, calls to this and its corresponding unlock
+ * should be contained entirely within the locked portion of LC_NUMERIC. This
+ * mutex should be used only in very short sections of code, while
+ * LC_NUMERIC_LOCK may span more operations. By always following this
+ * convention, deadlock should be impossible. But if necessary, the two
+ * mutexes could be combined.
+ *
+ * Actually, the two macros just below with the '_V' suffixes are used in just
+ * a few places where there is a broken localeconv(), but otherwise things are
+ * thread safe, and hence don't need locking. Just below LOCALE_LOCK and
+ * LOCALE_UNLOCK are defined in terms of these for use everywhere else */
+# define LOCALE_LOCK_V \
+ STMT_START { \
+ DEBUG_Lv(PerlIO_printf(Perl_debug_log, \
+ "%s: %d: locking locale\n", __FILE__, __LINE__)); \
+ MUTEX_LOCK(&PL_locale_mutex); \
+ } STMT_END
+# define LOCALE_UNLOCK_V \
+ STMT_START { \
+ DEBUG_Lv(PerlIO_printf(Perl_debug_log, \
+ "%s: %d: unlocking locale\n", __FILE__, __LINE__)); \
+ MUTEX_UNLOCK(&PL_locale_mutex); \
+ } STMT_END
+
+/* On windows, we just need the mutex for LOCALE_LOCK */
+# ifdef TS_W32_BROKEN_LOCALECONV
+# define LOCALE_LOCK NOOP
+# define LOCALE_UNLOCK NOOP
+# define LOCALE_INIT MUTEX_INIT(&PL_locale_mutex);
+# define LOCALE_TERM MUTEX_DESTROY(&PL_locale_mutex)
+# define LC_NUMERIC_LOCK(cond)
+# define LC_NUMERIC_UNLOCK
+# else
+# define LOCALE_LOCK LOCALE_LOCK_V
+# define LOCALE_UNLOCK LOCALE_UNLOCK_V
+
+ /* We also need to lock LC_NUMERIC for non-windows (hence Posix 2008)
+ * systems */
+# define LOCALE_INIT STMT_START { \
+ MUTEX_INIT(&PL_locale_mutex); \
+ MUTEX_INIT(&PL_lc_numeric_mutex); \
+ } STMT_END
+
+# define LOCALE_TERM STMT_START { \
+ MUTEX_DESTROY(&PL_locale_mutex); \
+ MUTEX_DESTROY(&PL_lc_numeric_mutex); \
+ _LOCALE_TERM_POSIX_2008; \
+ } STMT_END
+
+ /* This mutex is used to create critical sections where we want the
+ * LC_NUMERIC locale to be locked into either the C (standard) locale, or
+ * the underlying locale, so that other threads interrupting this one don't
+ * change it to the wrong state before we've had a chance to complete our
+ * operation. It can stay locked over an entire printf operation, for
+ * example. And so is made distinct from the LOCALE_LOCK mutex.
+ *
+ * This simulates kind of a general semaphore. The current thread will
+ * lock the mutex if the per-thread variable is zero, and then increments
+ * that variable. Each corresponding UNLOCK decrements the variable until
+ * it is 0, at which point it actually unlocks the mutex. Since the
+ * variable is per-thread, there is no race with other threads.
+ *
+ * The single argument is a condition to test for, and if true, to panic,
+ * as this would be an attempt to complement the LC_NUMERIC state, and
+ * we're not supposed to because it's locked.
+ *
+ * Clang improperly gives warnings for this, if not silenced:
+ * https://clang.llvm.org/docs/ThreadSafetyAnalysis.html#conditional-locks
+ * */
+# define LC_NUMERIC_LOCK(cond_to_panic_if_already_locked) \
+ CLANG_DIAG_IGNORE(-Wthread-safety) \
+ STMT_START { \
+ if (PL_lc_numeric_mutex_depth <= 0) { \
+ MUTEX_LOCK(&PL_lc_numeric_mutex); \
+ PL_lc_numeric_mutex_depth = 1; \
+ DEBUG_Lv(PerlIO_printf(Perl_debug_log, \
+ "%s: %d: locking lc_numeric; depth=1\n", \
+ __FILE__, __LINE__)); \
+ } \
+ else { \
+ PL_lc_numeric_mutex_depth++; \
+ DEBUG_Lv(PerlIO_printf(Perl_debug_log, \
+ "%s: %d: avoided lc_numeric_lock; depth=%d\n", \
+ __FILE__, __LINE__, PL_lc_numeric_mutex_depth)); \
+ if (cond_to_panic_if_already_locked) { \
+ Perl_croak_nocontext("panic: %s: %d: Trying to change" \
+ " LC_NUMERIC incompatibly", \
+ __FILE__, __LINE__); \
+ } \
+ } \
+ } STMT_END
+
+# define LC_NUMERIC_UNLOCK \
+ STMT_START { \
+ if (PL_lc_numeric_mutex_depth <= 1) { \
+ MUTEX_UNLOCK(&PL_lc_numeric_mutex); \
+ PL_lc_numeric_mutex_depth = 0; \
+ DEBUG_Lv(PerlIO_printf(Perl_debug_log, \
+ "%s: %d: unlocking lc_numeric; depth=0\n", \
+ __FILE__, __LINE__)); \
+ } \
+ else { \
+ PL_lc_numeric_mutex_depth--; \
+ DEBUG_Lv(PerlIO_printf(Perl_debug_log, \
+ "%s: %d: avoided lc_numeric_unlock; depth=%d\n", \
+ __FILE__, __LINE__, PL_lc_numeric_mutex_depth)); \
+ } \
+ } STMT_END \
+ CLANG_DIAG_RESTORE
+
+# endif /* End of needs locking LC_NUMERIC */
+#else /* Below is no locale sync needed */
+# define LOCALE_INIT
+# define LOCALE_LOCK
+# define LOCALE_LOCK_V
+# define LOCALE_UNLOCK
+# define LOCALE_UNLOCK_V
+# define LC_NUMERIC_LOCK(cond)
+# define LC_NUMERIC_UNLOCK
+# define LOCALE_TERM
#endif
#ifdef USE_LOCALE_NUMERIC
/* These macros are for toggling between the underlying locale (UNDERLYING or
- * LOCAL) and the C locale (STANDARD).
+ * LOCAL) and the C locale (STANDARD). (Actually we don't have to use the C
+ * locale if the underlying locale is indistinguishable from it in the numeric
+ * operations used by Perl, namely the decimal point, and even the thousands
+ * separator.)
=head1 Locale-related functions and macros
The private variable is used to save the current locale state, so
that the requisite matching call to L</RESTORE_LC_NUMERIC> can restore it.
+On threaded perls not operating with thread-safe functionality, this macro uses
+a mutex to force a critical section. Therefore the matching RESTORE should be
+close by, and guaranteed to be called.
+
=for apidoc Am|void|STORE_LC_NUMERIC_SET_TO_NEEDED
-This is used to help wrap XS or C code that that is C<LC_NUMERIC> locale-aware.
-This locale category is generally kept set to the C locale by Perl for
-backwards compatibility, and because most XS code that reads floating point
-values can cope only with the decimal radix character being a dot.
+This is used to help wrap XS or C code that is C<LC_NUMERIC> locale-aware.
+This locale category is generally kept set to a locale where the decimal radix
+character is a dot, and the separator between groups of digits is empty. This
+is because most XS code that reads floating point numbers is expecting them to
+have this syntax.
This macro makes sure the current C<LC_NUMERIC> state is set properly, to be
aware of locale if the call to the XS or C code from the Perl program is
...
}
+On threaded perls not operating with thread-safe functionality, this macro uses
+a mutex to force a critical section. Therefore the matching RESTORE should be
+close by, and guaranteed to be called.
+
=for apidoc Am|void|RESTORE_LC_NUMERIC
This is used in conjunction with one of the macros
L</STORE_LC_NUMERIC_SET_TO_NEEDED>
-and
-L</STORE_LC_NUMERIC_FORCE_TO_UNDERLYING>
-
-to properly restore the C<LC_NUMERIC> state.
+and L</STORE_LC_NUMERIC_FORCE_TO_UNDERLYING> to properly restore the
+C<LC_NUMERIC> state.
A call to L</DECLARATION_FOR_LC_NUMERIC_MANIPULATION> must have been made to
declare at compile time a private variable used by this macro and the two
*/
+/* If the underlying numeric locale has a non-dot decimal point or has a
+ * non-empty floating point thousands separator, the current locale is instead
+ * generally kept in the C locale instead of that underlying locale. The
+ * current status is known by looking at two words. One is non-zero if the
+ * current numeric locale is the standard C/POSIX one or is indistinguishable
+ * from C. The other is non-zero if the current locale is the underlying
+ * locale. Both can be non-zero if, as often happens, the underlying locale is
+ * C or indistinguishable from it.
+ *
+ * khw believes the reason for the variables instead of the bits in a single
+ * word is to avoid having to have masking instructions. */
+
# define _NOT_IN_NUMERIC_STANDARD (! PL_numeric_standard)
/* We can lock the category to stay in the C locale, making requests to the
* contrary be noops, in the dynamic scope by setting PL_numeric_standard to 2.
* */
# define _NOT_IN_NUMERIC_UNDERLYING \
- (! PL_numeric_underlying && PL_numeric_standard < 2)
+ (! PL_numeric_underlying && PL_numeric_standard < 2)
# define DECLARATION_FOR_LC_NUMERIC_MANIPULATION \
void (*_restore_LC_NUMERIC_function)(pTHX) = NULL
# define STORE_LC_NUMERIC_SET_TO_NEEDED() \
- if (IN_LC(LC_NUMERIC)) { \
- if (_NOT_IN_NUMERIC_UNDERLYING) { \
- Perl_set_numeric_underlying(aTHX); \
- _restore_LC_NUMERIC_function = &Perl_set_numeric_standard; \
- } \
- } \
- else { \
- if (_NOT_IN_NUMERIC_STANDARD) { \
- SET_NUMERIC_STANDARD(); \
- _restore_LC_NUMERIC_function = &Perl_set_numeric_underlying; \
- } \
- }
+ STMT_START { \
+ LC_NUMERIC_LOCK( \
+ (IN_LC(LC_NUMERIC) && _NOT_IN_NUMERIC_UNDERLYING) \
+ || _NOT_IN_NUMERIC_STANDARD); \
+ if (IN_LC(LC_NUMERIC)) { \
+ if (_NOT_IN_NUMERIC_UNDERLYING) { \
+ Perl_set_numeric_underlying(aTHX); \
+ _restore_LC_NUMERIC_function \
+ = &Perl_set_numeric_standard; \
+ } \
+ } \
+ else { \
+ if (_NOT_IN_NUMERIC_STANDARD) { \
+ Perl_set_numeric_standard(aTHX); \
+ _restore_LC_NUMERIC_function \
+ = &Perl_set_numeric_underlying; \
+ } \
+ } \
+ } STMT_END
# define RESTORE_LC_NUMERIC() \
- if (_restore_LC_NUMERIC_function) { \
- _restore_LC_NUMERIC_function(aTHX); \
- }
+ STMT_START { \
+ if (_restore_LC_NUMERIC_function) { \
+ _restore_LC_NUMERIC_function(aTHX); \
+ } \
+ LC_NUMERIC_UNLOCK; \
+ } STMT_END
/* The next two macros set unconditionally. These should be rarely used, and
* only after being sure that this is what is needed */
# define SET_NUMERIC_STANDARD() \
- STMT_START { if (_NOT_IN_NUMERIC_STANDARD) \
- Perl_set_numeric_standard(aTHX); \
- } STMT_END
+ STMT_START { \
+ DEBUG_Lv(PerlIO_printf(Perl_debug_log, \
+ "%s: %d: lc_numeric standard=%d\n", \
+ __FILE__, __LINE__, PL_numeric_standard)); \
+ Perl_set_numeric_standard(aTHX); \
+ DEBUG_Lv(PerlIO_printf(Perl_debug_log, \
+ "%s: %d: lc_numeric standard=%d\n", \
+ __FILE__, __LINE__, PL_numeric_standard)); \
+ } STMT_END
# define SET_NUMERIC_UNDERLYING() \
- STMT_START { if (_NOT_IN_NUMERIC_UNDERLYING) \
- Perl_set_numeric_underlying(aTHX); } STMT_END
+ STMT_START { \
+ if (_NOT_IN_NUMERIC_UNDERLYING) { \
+ Perl_set_numeric_underlying(aTHX); \
+ } \
+ } STMT_END
/* The rest of these LC_NUMERIC macros toggle to one or the other state, with
* the RESTORE_foo ones called to switch back, but only if need be */
-# define STORE_LC_NUMERIC_UNDERLYING_SET_STANDARD() \
- bool _was_underlying = _NOT_IN_NUMERIC_STANDARD; \
- if (_was_underlying) Perl_set_numeric_standard(aTHX);
-
-/* Doesn't change to underlying locale unless within the scope of some form of
- * 'use locale'. This is the usual desired behavior. */
-# define STORE_LC_NUMERIC_STANDARD_SET_UNDERLYING() \
- bool _was_standard = _NOT_IN_NUMERIC_UNDERLYING \
- && IN_LC(LC_NUMERIC); \
- if (_was_standard) Perl_set_numeric_underlying(aTHX);
+# define STORE_LC_NUMERIC_SET_STANDARD() \
+ STMT_START { \
+ LC_NUMERIC_LOCK(_NOT_IN_NUMERIC_STANDARD); \
+ if (_NOT_IN_NUMERIC_STANDARD) { \
+ _restore_LC_NUMERIC_function = &Perl_set_numeric_underlying;\
+ Perl_set_numeric_standard(aTHX); \
+ } \
+ } STMT_END
/* Rarely, we want to change to the underlying locale even outside of 'use
* locale'. This is principally in the POSIX:: functions */
-# define STORE_LC_NUMERIC_FORCE_TO_UNDERLYING() \
- if (_NOT_IN_NUMERIC_UNDERLYING) { \
- Perl_set_numeric_underlying(aTHX); \
- _restore_LC_NUMERIC_function = &Perl_set_numeric_standard; \
- }
+# define STORE_LC_NUMERIC_FORCE_TO_UNDERLYING() \
+ STMT_START { \
+ LC_NUMERIC_LOCK(_NOT_IN_NUMERIC_UNDERLYING); \
+ if (_NOT_IN_NUMERIC_UNDERLYING) { \
+ Perl_set_numeric_underlying(aTHX); \
+ _restore_LC_NUMERIC_function = &Perl_set_numeric_standard; \
+ } \
+ } STMT_END
/* Lock/unlock to the C locale until unlock is called. This needs to be
* recursively callable. [perl #128207] */
-# define LOCK_LC_NUMERIC_STANDARD() \
- (__ASSERT_(PL_numeric_standard) \
- PL_numeric_standard++)
-# define UNLOCK_LC_NUMERIC_STANDARD() \
- STMT_START { \
- if (PL_numeric_standard > 1) { \
- PL_numeric_standard--; \
- } \
- else { \
- assert(0); \
- } \
- } STMT_END
-
-# define RESTORE_LC_NUMERIC_UNDERLYING() \
- if (_was_underlying) Perl_set_numeric_underlying(aTHX);
+# define LOCK_LC_NUMERIC_STANDARD() \
+ STMT_START { \
+ DEBUG_Lv(PerlIO_printf(Perl_debug_log, \
+ "%s: %d: lock lc_numeric_standard: new depth=%d\n", \
+ __FILE__, __LINE__, PL_numeric_standard + 1)); \
+ __ASSERT_(PL_numeric_standard) \
+ PL_numeric_standard++; \
+ } STMT_END
-# define RESTORE_LC_NUMERIC_STANDARD() \
- if (_restore_LC_NUMERIC_function) { \
- _restore_LC_NUMERIC_function(aTHX); \
- }
+# define UNLOCK_LC_NUMERIC_STANDARD() \
+ STMT_START { \
+ if (PL_numeric_standard > 1) { \
+ PL_numeric_standard--; \
+ } \
+ else { \
+ assert(0); \
+ } \
+ DEBUG_Lv(PerlIO_printf(Perl_debug_log, \
+ "%s: %d: lc_numeric_standard decrement lock, new depth=%d\n", \
+ __FILE__, __LINE__, PL_numeric_standard)); \
+ } STMT_END
#else /* !USE_LOCALE_NUMERIC */
# define SET_NUMERIC_STANDARD()
# define SET_NUMERIC_UNDERLYING()
# define IS_NUMERIC_RADIX(a, b) (0)
-# define STORE_LC_NUMERIC_UNDERLYING_SET_STANDARD()
-# define STORE_LC_NUMERIC_STANDARD_SET_UNDERLYING()
-# define STORE_LC_NUMERIC_FORCE_TO_UNDERLYING()
-# define RESTORE_LC_NUMERIC_UNDERLYING()
-# define RESTORE_LC_NUMERIC_STANDARD()
# define DECLARATION_FOR_LC_NUMERIC_MANIPULATION
+# define STORE_LC_NUMERIC_SET_STANDARD()
+# define STORE_LC_NUMERIC_FORCE_TO_UNDERLYING()
# define STORE_LC_NUMERIC_SET_TO_NEEDED()
# define RESTORE_LC_NUMERIC()
# define LOCK_LC_NUMERIC_STANDARD()
#define Atof my_atof
-/* Back-compat names */
-#define DECLARATION_FOR_STORE_LC_NUMERIC_SET_TO_NEEDED \
- DECLARATION_FOR_LC_NUMERIC_MANIPULATION
-#define DECLARE_STORE_LC_NUMERIC_SET_TO_NEEDED() \
- DECLARATION_FOR_STORE_LC_NUMERIC_SET_TO_NEEDED; \
- STORE_LC_NUMERIC_SET_TO_NEEDED();
-#define LOCK_NUMERIC_STANDARD() LOCK_LC_NUMERIC_STANDARD()
-#define RESTORE_NUMERIC_LOCAL() RESTORE_LC_NUMERIC_UNDERLYING()
-#define RESTORE_NUMERIC_STANDARD() RESTORE_LC_NUMERIC_STANDARD()
-#define SET_NUMERIC_LOCAL() SET_NUMERIC_UNDERLYING()
-#define STORE_NUMERIC_LOCAL_SET_STANDARD() \
- STORE_LC_NUMERIC_UNDERLYING_SET_STANDARD()
-#define STORE_NUMERIC_STANDARD_SET_LOCAL() \
- STORE_LC_NUMERIC_STANDARD_SET_UNDERLYING()
-#define STORE_NUMERIC_STANDARD_FORCE_LOCAL() \
- STORE_LC_NUMERIC_FORCE_TO_UNDERLYING()
-#define UNLOCK_NUMERIC_STANDARD() UNLOCK_LC_NUMERIC_STANDARD()
-
-
-
#ifdef USE_QUADMATH
# define Perl_strtod(s, e) strtoflt128(s, e)
#elif defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)