# undef PERL_TRACK_MEMPOOL
#endif
+#ifdef DEBUGGING
+# define dTHX_DEBUGGING dTHX
+#else
+# define dTHX_DEBUGGING dNOOP
+#endif
+
#define STATIC static
#ifndef PERL_CORE
/* on gcc (and clang), specify that a warning should be temporarily
* ignored; e.g.
*
- * GCC_DIAG_IGNORE(-Wmultichar);
+ * GCC_DIAG_IGNORE_DECL(-Wmultichar);
* char b = 'ab';
- * GCC_DIAG_RESTORE;
+ * GCC_DIAG_RESTORE_DECL;
*
* based on http://dbp-consulting.com/tutorials/SuppressingGCCWarnings.html
*
* Note that "pragma GCC diagnostic push/pop" was added in GCC 4.6, Mar 2011;
* clang only pretends to be GCC 4.2, but still supports push/pop.
*
- * Note on usage: on non-gcc (or lookalike, like clang) compilers
- * one cannot use these with a semicolon at file (global) level without
- * warnings since they are defined as empty, which leads into the terminating
- * semicolon being left alone on a line:
- * ;
- * which makes compilers mildly cranky. Therefore at file level one
- * should use the GCC_DIAG_IGNORE and GCC_DIAG_RESTORE macros *without*
- * the semicolons.
+ * Note on usage: all macros must be used at a place where a declaration
+ * or statement can occur, i.e., not in the middle of an expression.
+ * *_DIAG_IGNORE() and *_DIAG_RESTORE can be used in any such place, but
+ * must be used without a following semicolon. *_DIAG_IGNORE_DECL() and
+ * *_DIAG_RESTORE_DECL must be used with a following semicolon, and behave
+ * syntactically as declarations (like dNOOP). *_DIAG_IGNORE_STMT()
+ * and *_DIAG_RESTORE_STMT must be used with a following semicolon,
+ * and behave syntactically as statements (like NOOP).
*
- * (A dead-on-arrival solution would be to try to define the macros as
- * NOOP or dNOOP, those don't work both inside functions and outside.)
*/
#if defined(__clang__) || defined(__clang) || \
# define GCC_DIAG_IGNORE(w)
# define GCC_DIAG_RESTORE
#endif
+#define GCC_DIAG_IGNORE_DECL(x) GCC_DIAG_IGNORE(x) dNOOP
+#define GCC_DIAG_RESTORE_DECL GCC_DIAG_RESTORE dNOOP
+#define GCC_DIAG_IGNORE_STMT(x) GCC_DIAG_IGNORE(x) NOOP
+#define GCC_DIAG_RESTORE_STMT GCC_DIAG_RESTORE NOOP
/* for clang specific pragmas */
#if defined(__clang__) || defined(__clang)
# define CLANG_DIAG_PRAGMA(x) _Pragma (#x)
# define CLANG_DIAG_IGNORE(w)
# define CLANG_DIAG_RESTORE
#endif
+#define CLANG_DIAG_IGNORE_DECL(x) CLANG_DIAG_IGNORE(x) dNOOP
+#define CLANG_DIAG_RESTORE_DECL CLANG_DIAG_RESTORE dNOOP
+#define CLANG_DIAG_IGNORE_STMT(x) CLANG_DIAG_IGNORE(x) NOOP
+#define CLANG_DIAG_RESTORE_STMT CLANG_DIAG_RESTORE NOOP
#define NOOP /*EMPTY*/(void)0
-/* cea2e8a9dd23747f accidentally lost the comment originally from the first
- check in of thread.h, explaining why we need dNOOP at all: */
-/* Rats: if dTHR is just blank then the subsequent ";" throws an error */
-/* Declaring a *function*, instead of a variable, ensures that we don't rely
- on being able to suppress "unused" warnings. */
-#ifdef __cplusplus
-#define dNOOP (void)0
-#else
-#define dNOOP extern int Perl___notused(void)
-#endif
+#define dNOOP struct Perl___notused_struct
#ifndef pTHX
/* Don't bother defining tTHX ; using it outside
cewchar.h includes a correct definition of MB_CUR_MAX and it is copied here
since cewchar.h can't be included this early */
#if defined(UNDER_CE) && (_MSC_VER < 1300)
-# define MB_CUR_MAX 1
+# define MB_CUR_MAX 1uL
#endif
# include <stdarg.h>
# 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
+
#include <setjmp.h>
#ifdef I_SYS_PARAM
EXTERN_C int usleep(unsigned int);
#endif
-#ifdef PERL_CORE
+/* macros for correct constant construction. These are in C99 <stdint.h>
+ * (so they will not be available in strict C89 mode), but they are nice, so
+ * let's define them if necessary. */
+#ifndef UINT16_C
+# if INTSIZE >= 2
+# define UINT16_C(x) ((U16_TYPE)x##U)
+# else
+# define UINT16_C(x) ((U16_TYPE)x##UL)
+# endif
+#endif
-/* macros for correct constant construction */
-# if INTSIZE >= 2
-# define U16_CONST(x) ((U16)x##U)
-# else
-# define U16_CONST(x) ((U16)x##UL)
-# endif
+#ifndef UINT32_C
+# if INTSIZE >= 4
+# define UINT32_C(x) ((U32_TYPE)x##U)
+# else
+# define UINT32_C(x) ((U32_TYPE)x##UL)
+# endif
+#endif
-# if INTSIZE >= 4
-# define U32_CONST(x) ((U32)x##U)
-# else
-# define U32_CONST(x) ((U32)x##UL)
-# endif
+#ifdef I_STDINT
+ typedef intmax_t PERL_INTMAX_T;
+ typedef uintmax_t PERL_UINTMAX_T;
+#endif
+
+/* N.B. We use QUADKIND here instead of HAS_QUAD here, because that doesn't
+ * actually mean what it has always been documented to mean (see RT #119753)
+ * and is explicitly turned off outside of core with dire warnings about
+ * removing the undef. */
+
+#if defined(QUADKIND)
+# undef PeRl_INT64_C
+# undef PeRl_UINT64_C
+/* Prefer the native integer types (int and long) over long long
+ * (which is not C89) and Win32-specific __int64. */
+# if QUADKIND == QUAD_IS_INT && INTSIZE == 8
+# define PeRl_INT64_C(c) (c)
+# define PeRl_UINT64_C(c) CAT2(c,U)
+# endif
+# if QUADKIND == QUAD_IS_LONG && LONGSIZE == 8
+# define PeRl_INT64_C(c) CAT2(c,L)
+# define PeRl_UINT64_C(c) CAT2(c,UL)
+# endif
+# if QUADKIND == QUAD_IS_LONG_LONG && defined(HAS_LONG_LONG)
+# define PeRl_INT64_C(c) CAT2(c,LL)
+# define PeRl_UINT64_C(c) CAT2(c,ULL)
+# endif
+# if QUADKIND == QUAD_IS___INT64
+# define PeRl_INT64_C(c) CAT2(c,I64)
+# define PeRl_UINT64_C(c) CAT2(c,UI64)
+# endif
+# ifndef PeRl_INT64_C
+# define PeRl_INT64_C(c) ((I64)(c)) /* last resort */
+# define PeRl_UINT64_C(c) ((U64TYPE)(c))
+# endif
+/* In OS X the INT64_C/UINT64_C are defined with LL/ULL, which will
+ * not fly with C89-pedantic gcc, so let's undefine them first so that
+ * we can redefine them with our native integer preferring versions. */
+# if defined(PERL_DARWIN) && defined(PERL_GCC_PEDANTIC)
+# undef INT64_C
+# undef UINT64_C
+# endif
+# ifndef INT64_C
+# define INT64_C(c) PeRl_INT64_C(c)
+# endif
+# ifndef UINT64_C
+# define UINT64_C(c) PeRl_UINT64_C(c)
+# endif
-# ifdef HAS_QUAD
-# if INTSIZE >= 8
-# define U64_CONST(x) ((U64)x##U)
-# elif LONGSIZE >= 8
-# define U64_CONST(x) ((U64)x##UL)
-# elif QUADKIND == QUAD_IS_LONG_LONG
-# define U64_CONST(x) ((U64)x##ULL)
-# elif QUADKIND == QUAD_IS___INT64
-# define U64_CONST(x) ((U64)x##UI64)
-# else /* best guess we can make */
-# define U64_CONST(x) ((U64)x##UL)
+# ifndef I_STDINT
+ typedef I64TYPE PERL_INTMAX_T;
+ typedef U64TYPE PERL_UINTMAX_T;
# endif
-# endif
+# ifndef INTMAX_C
+# define INTMAX_C(c) INT64_C(c)
+# endif
+# ifndef UINTMAX_C
+# define UINTMAX_C(c) UINT64_C(c)
+# endif
+
+#else /* below QUADKIND is undefined */
+
+/* Perl doesn't work on 16 bit systems, so must be 32 bit */
+# ifndef I_STDINT
+ typedef I32TYPE PERL_INTMAX_T;
+ typedef U32TYPE PERL_UINTMAX_T;
+# endif
+# ifndef INTMAX_C
+# define INTMAX_C(c) INT32_C(c)
+# endif
+# ifndef UINTMAX_C
+# define UINTMAX_C(c) UINT32_C(c)
+# endif
+
+#endif /* no QUADKIND */
+
+#ifdef PERL_CORE
/* byte-swapping functions for big-/little-endian conversion */
# define _swab_16_(x) ((U16)( \
- (((U16)(x) & U16_CONST(0x00ff)) << 8) | \
- (((U16)(x) & U16_CONST(0xff00)) >> 8) ))
+ (((U16)(x) & UINT16_C(0x00ff)) << 8) | \
+ (((U16)(x) & UINT16_C(0xff00)) >> 8) ))
# define _swab_32_(x) ((U32)( \
- (((U32)(x) & U32_CONST(0x000000ff)) << 24) | \
- (((U32)(x) & U32_CONST(0x0000ff00)) << 8) | \
- (((U32)(x) & U32_CONST(0x00ff0000)) >> 8) | \
- (((U32)(x) & U32_CONST(0xff000000)) >> 24) ))
+ (((U32)(x) & UINT32_C(0x000000ff)) << 24) | \
+ (((U32)(x) & UINT32_C(0x0000ff00)) << 8) | \
+ (((U32)(x) & UINT32_C(0x00ff0000)) >> 8) | \
+ (((U32)(x) & UINT32_C(0xff000000)) >> 24) ))
# ifdef HAS_QUAD
# define _swab_64_(x) ((U64)( \
- (((U64)(x) & U64_CONST(0x00000000000000ff)) << 56) | \
- (((U64)(x) & U64_CONST(0x000000000000ff00)) << 40) | \
- (((U64)(x) & U64_CONST(0x0000000000ff0000)) << 24) | \
- (((U64)(x) & U64_CONST(0x00000000ff000000)) << 8) | \
- (((U64)(x) & U64_CONST(0x000000ff00000000)) >> 8) | \
- (((U64)(x) & U64_CONST(0x0000ff0000000000)) >> 24) | \
- (((U64)(x) & U64_CONST(0x00ff000000000000)) >> 40) | \
- (((U64)(x) & U64_CONST(0xff00000000000000)) >> 56) ))
+ (((U64)(x) & UINT64_C(0x00000000000000ff)) << 56) | \
+ (((U64)(x) & UINT64_C(0x000000000000ff00)) << 40) | \
+ (((U64)(x) & UINT64_C(0x0000000000ff0000)) << 24) | \
+ (((U64)(x) & UINT64_C(0x00000000ff000000)) << 8) | \
+ (((U64)(x) & UINT64_C(0x000000ff00000000)) >> 8) | \
+ (((U64)(x) & UINT64_C(0x0000ff0000000000)) >> 24) | \
+ (((U64)(x) & UINT64_C(0x00ff000000000000)) >> 40) | \
+ (((U64)(x) & UINT64_C(0xff00000000000000)) >> 56) ))
# endif
/* The old value was hard coded at 1008. (4096-16) seems to be a bit faster,
*/
/* Note that we do not check against snprintf()/vsnprintf() returning
- * negative values because that is non-standard behaviour and we now
- * assume a working C89 implementation. */
+ * negative values because that is non-standard behaviour and we use
+ * snprintf/vsnprintf only iff HAS_VSNPRINTF has been defined, and
+ * that should be true only if the snprintf()/vsnprintf() are true
+ * to the standard. */
#define PERL_SNPRINTF_CHECK(len, max, api) STMT_START { if ((max) > 0 && (Size_t)len > (max)) Perl_croak_nocontext("panic: %s buffer overflow", STRINGIFY(api)); } STMT_END
#ifdef USE_QUADMATH
# define my_snprintf Perl_my_snprintf
# define PERL_MY_SNPRINTF_GUARDED
-#elif defined(HAS_C99_VARIADIC_MACROS) && !(defined(DEBUGGING) && !defined(PERL_USE_GCC_BRACE_GROUPS)) && !defined(PERL_GCC_PEDANTIC)
+#elif defined(HAS_SNPRINTF) && defined(HAS_C99_VARIADIC_MACROS) && !(defined(DEBUGGING) && !defined(PERL_USE_GCC_BRACE_GROUPS)) && !defined(PERL_GCC_PEDANTIC)
# ifdef PERL_USE_GCC_BRACE_GROUPS
# define my_snprintf(buffer, max, ...) ({ int len = snprintf(buffer, max, __VA_ARGS__); PERL_SNPRINTF_CHECK(len, max, snprintf); len; })
# define PERL_MY_SNPRINTF_GUARDED
/* There is no quadmath_vsnprintf, and therefore my_vsnprintf()
* dies if called under USE_QUADMATH. */
-#if defined(HAS_C99_VARIADIC_MACROS) && !(defined(DEBUGGING) && !defined(PERL_USE_GCC_BRACE_GROUPS)) && !defined(PERL_GCC_PEDANTIC)
+#if defined(HAS_VSNPRINTF) && defined(HAS_C99_VARIADIC_MACROS) && !(defined(DEBUGGING) && !defined(PERL_USE_GCC_BRACE_GROUPS)) && !defined(PERL_GCC_PEDANTIC)
# ifdef PERL_USE_GCC_BRACE_GROUPS
# define my_vsnprintf(buffer, max, ...) ({ int len = vsnprintf(buffer, max, __VA_ARGS__); PERL_SNPRINTF_CHECK(len, max, vsnprintf); len; })
# define PERL_MY_VSNPRINTF_GUARDED
typedef struct padnamelist PADNAMELIST;
typedef struct padname PADNAME;
-/* enable PERL_OP_PARENT by default */
-#if !defined(PERL_OP_PARENT) && !defined(PERL_NO_OP_PARENT)
+/* always enable PERL_OP_PARENT */
+#if !defined(PERL_OP_PARENT)
# define PERL_OP_PARENT
#endif
*/
/* The following are stored in $^H{sort}, not in PL_hints */
-#define HINT_SORT_SORT_BITS 0x000000FF /* allow 256 different ones */
-#define HINT_SORT_QUICKSORT 0x00000001
-#define HINT_SORT_MERGESORT 0x00000002
#define HINT_SORT_STABLE 0x00000100 /* sort styles */
#define HINT_SORT_UNSTABLE 0x00000200
#define PERLDB_LINE_OR_SAVESRC (PL_perldb & (PERLDBf_LINE | PERLDBf_SAVESRC))
-#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)
-
- /* 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 */
+#ifdef USE_ITHREADS
+# define KEYWORD_PLUGIN_MUTEX_INIT MUTEX_INIT(&PL_keyword_plugin_mutex)
+# define KEYWORD_PLUGIN_MUTEX_LOCK MUTEX_LOCK(&PL_keyword_plugin_mutex)
+# define KEYWORD_PLUGIN_MUTEX_UNLOCK MUTEX_UNLOCK(&PL_keyword_plugin_mutex)
+# define KEYWORD_PLUGIN_MUTEX_TERM MUTEX_DESTROY(&PL_keyword_plugin_mutex)
+#else
+# define KEYWORD_PLUGIN_MUTEX_INIT NOOP
+# define KEYWORD_PLUGIN_MUTEX_LOCK NOOP
+# define KEYWORD_PLUGIN_MUTEX_UNLOCK NOOP
+# define KEYWORD_PLUGIN_MUTEX_TERM NOOP
+#endif
-# define HAS_POSIX_2008_LOCALE
-# endif
+#ifdef USE_LOCALE /* These locale things are all subject to change */
-/* We create a C locale object unconditionally if we have the functions to do
- * so; hence must destroy it unconditionally at the end */
+ /* 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
} STMT_END
# endif
-# ifndef USE_ITHREADS
+# if ! defined(USE_ITHREADS) || defined(USE_THREAD_SAFE_LOCALE)
# define LOCALE_INIT
# define LOCALE_LOCK
# define LOCALE_UNLOCK
+# define LC_NUMERIC_LOCK(cond)
+# define LC_NUMERIC_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)
+# else
+# define LOCALE_INIT STMT_START { \
+ MUTEX_INIT(&PL_locale_mutex); \
+ MUTEX_INIT(&PL_lc_numeric_mutex); \
+ } 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 */
+# define LC_NUMERIC_LOCK(cond_to_panic_if_already_locked) \
+ 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
+
+/* 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 */
+# define LOCALE_LOCK \
+ 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 \
+ STMT_START { \
+ DEBUG_Lv(PerlIO_printf(Perl_debug_log, \
+ "%s: %d: unlocking locale\n", __FILE__, __LINE__)); \
+ MUTEX_UNLOCK(&PL_locale_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
-# ifdef HAS_POSIX_2008_LOCALE
-# define USE_POSIX_2008_LOCALE
-# define USE_THREAD_SAFE_LOCALE
-# endif
# endif
/* Returns TRUE if the plain locale pragma without a parameter is in effect
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.
...
}
+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
*/
+/* The numeric locale is generally kept in the C locale instead of the
+ * 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.
+ * 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.
+ *
+ * Its slightly more complicated than this, as the PL_numeric_standard variable
+ * is set if the current numeric locale is indistinguishable from the C locale.
+ * This happens when the radix character is a dot, and the thousands separator
+ * is the empty string.
+ *
+ * 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: standard=%d\n", \
+ __FILE__, __LINE__, PL_numeric_standard)); \
+ Perl_set_numeric_standard(aTHX); \
+ DEBUG_Lv(PerlIO_printf(Perl_debug_log, "%s: %d: 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 LOCK_LC_NUMERIC_STANDARD() \
+ STMT_START { \
+ DEBUG_Lv(PerlIO_printf(Perl_debug_log, "%s: %d: standard=%d\n", \
+ __FILE__, __LINE__, PL_numeric_standard)); \
+ __ASSERT_(PL_numeric_standard) \
+ PL_numeric_standard++; \
+ } STMT_END
+
# define UNLOCK_LC_NUMERIC_STANDARD() \
STMT_START { \
if (PL_numeric_standard > 1) { \
} \
} STMT_END
-# define RESTORE_LC_NUMERIC_UNDERLYING() \
- if (_was_underlying) Perl_set_numeric_underlying(aTHX);
-
-# define RESTORE_LC_NUMERIC_STANDARD() \
- if (_restore_LC_NUMERIC_function) { \
- _restore_LC_NUMERIC_function(aTHX); \
- }
-
#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() \
- STMT_START { \
- DECLARATION_FOR_LC_NUMERIC_MANIPULATION; \
- STORE_LC_NUMERIC_SET_TO_NEEDED(); \
- } STMT_END
-#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)
*/
/* The quadmath literals are anon structs which -Wc++-compat doesn't like. */
-GCC_DIAG_IGNORE(-Wc++-compat)
+GCC_DIAG_IGNORE_DECL(-Wc++-compat);
# ifdef USE_QUADMATH
/* Cannot use HUGE_VALQ for PL_inf because not a compile-time
# endif
# endif
-GCC_DIAG_RESTORE
+GCC_DIAG_RESTORE_DECL;
#else
https://perl5.git.perl.org / perl5.git / blobdiff