X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/371d5d44b054ca1540da57f7be95194f1d92f449..05b4a618e0f17cd89317fce1e24846b2bd34afca:/perl.h diff --git a/perl.h b/perl.h index b6e0c3e..751df86 100644 --- a/perl.h +++ b/perl.h @@ -25,11 +25,18 @@ #ifdef PERL_MICRO # include "uconfig.h" #else -# ifndef USE_CROSS_COMPILE -# include "config.h" -# else -# include "xconfig.h" -# endif +# include "config.h" +#endif + +/* NOTE 1: that with gcc -std=c89 the __STDC_VERSION__ is *not* defined + * because the __STDC_VERSION__ became a thing only with C90. Therefore, + * with gcc, HAS_C99 will never become true as long as we use -std=c89. + + * NOTE 2: headers lie. Do not expect that if HAS_C99 gets to be true, + * all the C99 features are there and are correct. */ +#if (defined(__STDC_VERSION__) && __STDC_VERSION__ >= 199901L) || \ + defined(_STDC_C99) +# define HAS_C99 1 #endif /* See L for detailed notes on @@ -179,6 +186,7 @@ # define pTHX_7 8 # define pTHX_8 9 # define pTHX_9 10 +# define pTHX_12 13 # if defined(DEBUGGING) && !defined(PERL_TRACK_MEMPOOL) # define PERL_TRACK_MEMPOOL # endif @@ -310,26 +318,73 @@ /* gcc -Wall: * for silencing unused variables that are actually used most of the time, - * but we cannot quite get rid of, such as "ax" in PPCODE+noargs xsubs + * but we cannot quite get rid of, such as "ax" in PPCODE+noargs xsubs, + * or variables/arguments that are used only in certain configurations. */ #ifndef PERL_UNUSED_ARG # if defined(lint) && defined(S_SPLINT_S) /* www.splint.org */ # include # define PERL_UNUSED_ARG(x) NOTE(ARGUNUSED(x)) # else -# define PERL_UNUSED_ARG(x) ((void)x) +# define PERL_UNUSED_ARG(x) ((void)sizeof(x)) # endif #endif #ifndef PERL_UNUSED_VAR -# define PERL_UNUSED_VAR(x) ((void)x) +# define PERL_UNUSED_VAR(x) ((void)sizeof(x)) #endif -#ifdef USE_ITHREADS +#if defined(USE_ITHREADS) || defined(PERL_GLOBAL_STRUCT) # define PERL_UNUSED_CONTEXT PERL_UNUSED_ARG(my_perl) #else # define PERL_UNUSED_CONTEXT #endif +/* gcc (-ansi) -pedantic doesn't allow gcc statement expressions, + * g++ allows them but seems to have problems with them + * (insane errors ensue). + * g++ does not give insane errors now (RMB 2008-01-30, gcc 4.2.2). + */ +#if defined(PERL_GCC_PEDANTIC) || \ + (defined(__GNUC__) && defined(__cplusplus) && \ + ((__GNUC__ < 4) || ((__GNUC__ == 4) && (__GNUC_MINOR__ < 2)))) +# ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN +# define PERL_GCC_BRACE_GROUPS_FORBIDDEN +# endif +#endif + +/* Use PERL_UNUSED_RESULT() to suppress the warnings about unused results + * of function calls, e.g. PERL_UNUSED_RESULT(foo(a, b)). + * + * The main reason for this is that the combination of gcc -Wunused-result + * (part of -Wall) and the __attribute__((warn_unused_result)) cannot + * be silenced with casting to void. This causes trouble when the system + * header files use the attribute. + * + * Use PERL_UNUSED_RESULT sparingly, though, since usually the warning + * is there for a good reason: you might lose success/failure information, + * or leak resources, or changes in resources. + * + * But sometimes you just want to ignore the return value, e.g. on + * codepaths soon ending up in abort, or in "best effort" attempts, + * or in situations where there is no good way to handle failures. + * + * Sometimes PERL_UNUSED_RESULT might not be the most natural way: + * another possibility is that you can capture the return value + * and use PERL_UNUSED_VAR on that. + * + * The __typeof__() is used instead of typeof() since typeof() is not + * available under strict C89, and because of compilers masquerading + * as gcc (clang and icc), we want exactly the gcc extension + * __typeof__ and nothing else. + */ +#ifndef PERL_UNUSED_RESULT +# if defined(__GNUC__) && defined(HASATTRIBUTE_WARN_UNUSED_RESULT) +# define PERL_UNUSED_RESULT(v) STMT_START { __typeof__(v) z = (v); (void)sizeof(z); } STMT_END +# else +# define PERL_UNUSED_RESULT(v) ((void)(v)) +# endif +#endif + /* on gcc (and clang), specify that a warning should be temporarily * ignored; e.g. * @@ -341,21 +396,32 @@ * * 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 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_FILE *without* + * the semicolons. + * + * (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) || \ +#if defined(__clang__) || defined(__clang) || \ (defined( __GNUC__) && ((__GNUC__ * 100) + __GNUC_MINOR__) >= 406) -# define GCC_DIAG_DO_PRAGMA_(x) _Pragma (#x) - +# define GCC_DIAG_PRAGMA(x) _Pragma (#x) +/* clang has "clang diagnostic" pragmas, but also understands gcc. */ # define GCC_DIAG_IGNORE(x) _Pragma("GCC diagnostic push") \ - GCC_DIAG_DO_PRAGMA_(GCC diagnostic ignored #x) + GCC_DIAG_PRAGMA(GCC diagnostic ignored #x) # define GCC_DIAG_RESTORE _Pragma("GCC diagnostic pop") #else # define GCC_DIAG_IGNORE(w) # define GCC_DIAG_RESTORE #endif - #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: */ @@ -369,7 +435,7 @@ #endif #ifndef pTHX -/* Don't bother defining tTHX and sTHX; using them outside +/* Don't bother defining tTHX ; using it outside * code guarded by PERL_IMPLICIT_CONTEXT is an error. */ # define pTHX void @@ -388,6 +454,7 @@ # define pTHX_7 7 # define pTHX_8 8 # define pTHX_9 9 +# define pTHX_12 12 #endif #ifndef dVAR @@ -449,19 +516,6 @@ # endif #endif -/* gcc (-ansi) -pedantic doesn't allow gcc statement expressions, - * g++ allows them but seems to have problems with them - * (insane errors ensue). - * g++ does not give insane errors now (RMB 2008-01-30, gcc 4.2.2). - */ -#if defined(PERL_GCC_PEDANTIC) || \ - (defined(__GNUC__) && defined(__cplusplus) && \ - ((__GNUC__ < 4) || ((__GNUC__ == 4) && (__GNUC_MINOR__ < 2)))) -# ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN -# define PERL_GCC_BRACE_GROUPS_FORBIDDEN -# endif -#endif - #if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) && !defined(__cplusplus) # ifndef PERL_USE_GCC_BRACE_GROUPS # define PERL_USE_GCC_BRACE_GROUPS @@ -542,7 +596,7 @@ * DANGER! Using NO_TAINT_SUPPORT or SILENT_NO_TAINT_SUPPORT * voids your nonexistent warranty! */ -#if SILENT_NO_TAINT_SUPPORT && !defined(NO_TAINT_SUPPORT) +#if defined(SILENT_NO_TAINT_SUPPORT) && !defined(NO_TAINT_SUPPORT) # define NO_TAINT_SUPPORT 1 #endif @@ -550,7 +604,7 @@ * operations into no-ops for a very modest speed-up. Enable only if you * know what you're doing: tests and CPAN modules' tests are bound to fail. */ -#if NO_TAINT_SUPPORT +#ifdef NO_TAINT_SUPPORT # define TAINT NOOP # define TAINT_NOT NOOP # define TAINT_IF(c) NOOP @@ -658,21 +712,11 @@ # endif #endif -#ifdef USE_NEXT_CTYPE +#ifdef I_STDINT +# include +#endif -#if NX_CURRENT_COMPILER_RELEASE >= 500 -# include -#else -# if NX_CURRENT_COMPILER_RELEASE >= 400 -# include -# else /* NX_CURRENT_COMPILER_RELEASE < 400 */ -# include -# endif /* NX_CURRENT_COMPILER_RELEASE >= 400 */ -#endif /* NX_CURRENT_COMPILER_RELEASE >= 500 */ - -#else /* !USE_NEXT_CTYPE */ #include -#endif /* USE_NEXT_CTYPE */ #ifdef METHOD /* Defined by OSF/1 v3.0 by ctype.h */ #undef METHOD @@ -706,6 +750,12 @@ # if !defined(NO_LOCALE_MONETARY) && defined(LC_MONETARY) # define USE_LOCALE_MONETARY # endif +# if !defined(NO_LOCALE_TIME) && defined(LC_TIME) +# define USE_LOCALE_TIME +# endif +# ifndef WIN32 /* No wrapper except on Windows */ +# define my_setlocale(a,b) setlocale(a,b) +# endif #endif /* !NO_LOCALE && HAS_SETLOCALE */ #include @@ -852,13 +902,18 @@ EXTERN_C int usleep(unsigned int); # define PERL_STRLEN_EXPAND_SHIFT 2 #endif -#if defined(STANDARD_C) && defined(I_STDDEF) +#if defined(STANDARD_C) && defined(I_STDDEF) && !defined(PERL_GCC_PEDANTIC) # include # define STRUCT_OFFSET(s,m) offsetof(s,m) #else # define STRUCT_OFFSET(s,m) (Size_t)(&(((s *)0)->m)) #endif +/* ptrdiff_t is C11, so undef it under pedantic builds */ +#ifdef PERL_GCC_PEDANTIC +# undef HAS_PTRDIFF_T +#endif + #ifndef __SYMBIAN32__ # if defined(I_STRING) || defined(__cplusplus) # include @@ -896,7 +951,7 @@ EXTERN_C int usleep(unsigned int); # define CHECK_MALLOC_TAINT(newval) \ CHECK_MALLOC_TOO_LATE_FOR_( \ if (newval) { \ - panic_write2("panic: tainting with $ENV{PERL_MALLOC_OPT}\n");\ + PERL_UNUSED_RESULT(panic_write2("panic: tainting with $ENV{PERL_MALLOC_OPT}\n"));\ exit(1); }) # define MALLOC_CHECK_TAINT(argc,argv,env) STMT_START { \ if (doing_taint(argc,argv,env)) { \ @@ -1165,6 +1220,7 @@ EXTERN_C char *crypt(const char *, const char *); # define SS_DEVOFFLINE SS$_DEVOFFLINE # define SS_IVCHAN SS$_IVCHAN # define SS_NORMAL SS$_NORMAL +# define SS_NOPRIV SS$_NOPRIV #else # define LIB_INVARG 0 # define RMS_DIR 0 @@ -1178,6 +1234,7 @@ EXTERN_C char *crypt(const char *, const char *); # define SS_DEVOFFLINE 0 # define SS_IVCHAN 0 # define SS_NORMAL 0 +# define SS_NOPRIV 0 #endif #ifdef WIN32 @@ -1305,10 +1362,6 @@ EXTERN_C char *crypt(const char *, const char *); /* Configure already sets Direntry_t */ #if defined(I_DIRENT) # include - /* NeXT needs dirent + sys/dir.h */ -# if defined(I_SYS_DIR) && (defined(NeXT) || defined(__NeXT__)) -# include -# endif #else # ifdef I_SYS_NDIR # include @@ -1507,12 +1560,14 @@ EXTERN_C char *crypt(const char *, const char *); * 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 + #if 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, len, ...) ({ int __len__ = snprintf(buffer, len, __VA_ARGS__); if ((len) > 0 && (Size_t)__len__ >= (len)) Perl_croak_nocontext("panic: snprintf buffer overflow"); __len__; }) +# define my_snprintf(buffer, max, ...) ({ int len = snprintf(buffer, max, __VA_ARGS__); PERL_SNPRINTF_CHECK(len, max, snprintf); len; }) # define PERL_MY_SNPRINTF_GUARDED # else -# define my_snprintf(buffer, len, ...) snprintf(buffer, len, __VA_ARGS__) +# define my_snprintf(buffer, max, ...) snprintf(buffer, max, __VA_ARGS__) # endif #else # define my_snprintf Perl_my_snprintf @@ -1521,16 +1576,47 @@ EXTERN_C char *crypt(const char *, const char *); #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, len, ...) ({ int __len__ = vsnprintf(buffer, len, __VA_ARGS__); if ((len) > 0 && (Size_t)__len__ >= (Size_t)(len)) Perl_croak_nocontext("panic: vsnprintf buffer overflow"); __len__; }) +# define my_vsnprintf(buffer, max, ...) ({ int len = vsnprintf(buffer, max, __VA_ARGS__); PERL_SNPRINTF_CHECK(len, max, vsnprintf); len; }) # define PERL_MY_VSNPRINTF_GUARDED # else -# define my_vsnprintf(buffer, len, ...) vsnprintf(buffer, len, __VA_ARGS__) +# define my_vsnprintf(buffer, max, ...) vsnprintf(buffer, max, __VA_ARGS__) # endif #else # define my_vsnprintf Perl_my_vsnprintf # define PERL_MY_VSNPRINTF_GUARDED #endif +/* You will definitely need to use the PERL_MY_SNPRINTF_POST_GUARD() + * or PERL_MY_VSNPRINTF_POST_GUARD() if you otherwise decide to ignore + * the result of my_snprintf() or my_vsnprintf(). (No, you should not + * completely ignore it: otherwise you cannot know whether your output + * was too long.) + * + * int len = my_sprintf(buf, max, ...); + * PERL_MY_SNPRINTF_POST_GUARD(len, max); + * + * The trick is that in certain platforms [a] the my_sprintf() already + * contains the sanity check, while in certain platforms [b] it needs + * to be done as a separate step. The POST_GUARD is that step-- in [a] + * platforms the POST_GUARD actually does nothing since the check has + * already been done. Watch out for the max being the same in both calls. + * + * If you actually use the snprintf/vsnprintf return value already, + * you assumedly are checking its validity somehow. But you can + * insert the POST_GUARD() also in that case. */ + +#ifndef PERL_MY_SNPRINTF_GUARDED +# define PERL_MY_SNPRINTF_POST_GUARD(len, max) PERL_SNPRINTF_CHECK(len, max, snprintf) +#else +# define PERL_MY_SNPRINTF_POST_GUARD(len, max) PERL_UNUSED_VAR(len) +#endif + +#ifndef PERL_MY_VSNPRINTF_GUARDED +# define PERL_MY_VSNPRINTF_POST_GUARD(len, max) PERL_SNPRINTF_CHECK(len, max, vsnprintf) +#else +# define PERL_MY_VSNPRINTF_POST_GUARD(len, max) PERL_UNUSED_VAR(len) +#endif + #ifdef HAS_STRLCAT # define my_strlcat strlcat #else @@ -1607,7 +1693,8 @@ typedef UVTYPE UV; # endif #endif -#define SSize_t_MAX (SSize_t)(~(size_t)0 >> 1) +#define Size_t_MAX (~(Size_t)0) +#define SSize_t_MAX (SSize_t)(~(Size_t)0 >> 1) #define IV_DIG (BIT_DIGITS(IVSIZE * 8)) #define UV_DIG (BIT_DIGITS(UVSIZE * 8)) @@ -1767,81 +1854,151 @@ typedef NVTYPE NV; # ifdef I_SUNMATH # include # endif -# define NV_DIG LDBL_DIG -# ifdef LDBL_MANT_DIG -# define NV_MANT_DIG LDBL_MANT_DIG -# endif -# ifdef LDBL_MIN -# define NV_MIN LDBL_MIN +# if defined(USE_QUADMATH) && defined(I_QUADMATH) +# include # endif -# ifdef LDBL_MAX -# define NV_MAX LDBL_MAX -# endif -# ifdef LDBL_MIN_10_EXP -# define NV_MIN_10_EXP LDBL_MIN_10_EXP -# endif -# ifdef LDBL_MAX_10_EXP -# define NV_MAX_10_EXP LDBL_MAX_10_EXP -# endif -# ifdef LDBL_EPSILON -# define NV_EPSILON LDBL_EPSILON -# endif -# ifdef LDBL_MAX -# define NV_MAX LDBL_MAX +# ifdef FLT128_DIG +# define NV_DIG FLT128_DIG +# define NV_MANT_DIG FLT128_MANT_DIG +# define NV_MIN FLT128_MIN +# define NV_MAX FLT128_MAX +# define NV_MIN_EXP FLT128_MIN_EXP +# define NV_MAX_EXP FLT128_MAX_EXP +# define NV_EPSILON FLT128_EPSILON +# define NV_MIN_10_EXP FLT128_MIN_10_EXP +# define NV_MAX_10_EXP FLT128_MAX_10_EXP +# define NV_INF HUGE_VALQ +# define NV_NAN nanq("0") +# elif defined(LDBL_DIG) +# define NV_DIG LDBL_DIG +# ifdef LDBL_MANT_DIG +# define NV_MANT_DIG LDBL_MANT_DIG +# endif +# ifdef LDBL_MIN +# define NV_MIN LDBL_MIN +# endif +# ifdef LDBL_MAX +# define NV_MAX LDBL_MAX +# endif +# ifdef LDBL_MIN_EXP +# define NV_MIN_EXP LDBL_MIN_EXP +# endif +# ifdef LDBL_MAX_EXP +# define NV_MAX_EXP LDBL_MAX_EXP +# endif +# ifdef LDBL_MIN_10_EXP +# define NV_MIN_10_EXP LDBL_MIN_10_EXP +# endif +# ifdef LDBL_MAX_10_EXP +# define NV_MAX_10_EXP LDBL_MAX_10_EXP +# endif +# ifdef LDBL_EPSILON +# define NV_EPSILON LDBL_EPSILON +# endif +# ifdef LDBL_MAX +# define NV_MAX LDBL_MAX /* Having LDBL_MAX doesn't necessarily mean that we have LDBL_MIN... -Allen */ -# else -# ifdef HUGE_VALL -# define NV_MAX HUGE_VALL # else -# ifdef HUGE_VAL -# define NV_MAX ((NV)HUGE_VAL) +# ifdef HUGE_VALL +# define NV_MAX HUGE_VALL # endif # endif # endif -# ifdef HAS_SQRTL +# if defined(USE_QUADMATH) && defined(I_QUADMATH) +# define Perl_acos acosq +# define Perl_asin asinq +# define Perl_atan atanq +# define Perl_atan2 atan2q +# define Perl_ceil ceilq +# define Perl_cos cosq +# define Perl_cosh coshq +# define Perl_exp expq +/* no Perl_fabs, but there's PERL_ABS */ +# define Perl_floor floorq +# define Perl_fmod fmodq +# define Perl_log logq +# define Perl_log10 log10q +# define Perl_pow powq +# define Perl_sin sinq +# define Perl_sinh sinhq +# define Perl_sqrt sqrtq +# define Perl_tan tanq +# define Perl_tanh tanhq +# define Perl_modf(x,y) modfq(x,y) +# define Perl_frexp(x,y) frexpq(x,y) +# define Perl_ldexp(x, y) ldexpq(x,y) +# define Perl_isinf(x) isinfq(x) +# define Perl_isnan(x) isnanq(x) +# define Perl_isfinite(x) !(isnanq(x) || isinfq(x)) +# elif defined(HAS_SQRTL) +# define Perl_acos acosl +# define Perl_asin asinl +# define Perl_atan atanl +# define Perl_atan2 atan2l +# define Perl_ceil ceill # define Perl_cos cosl -# define Perl_sin sinl -# define Perl_sqrt sqrtl +# define Perl_cosh coshl # define Perl_exp expl -# define Perl_log logl -# define Perl_atan2 atan2l -# define Perl_pow powl +/* no Perl_fabs, but there's PERL_ABS */ # define Perl_floor floorl -# define Perl_ceil ceill # define Perl_fmod fmodl +# define Perl_log logl +# define Perl_log10 log10l +# define Perl_pow powl +# define Perl_sin sinl +# define Perl_sinh sinhl +# define Perl_sqrt sqrtl +# define Perl_tan tanl +# define Perl_tanh tanhl # endif /* e.g. libsunmath doesn't have modfl and frexpl as of mid-March 2000 */ -# ifdef HAS_MODFL -# define Perl_modf(x,y) modfl(x,y) +# ifndef Perl_modf +# ifdef HAS_MODFL +# define Perl_modf(x,y) modfl(x,y) /* eg glibc 2.2 series seems to provide modfl on ppc and arm, but has no prototype in */ -# ifndef HAS_MODFL_PROTO +# ifndef HAS_MODFL_PROTO EXTERN_C long double modfl(long double, long double *); -# endif -# else -# if defined(HAS_AINTL) && defined(HAS_COPYSIGNL) +# endif +# elif (defined(HAS_TRUNCL) || defined(HAS_AINTL)) && defined(HAS_COPYSIGNL) extern long double Perl_my_modfl(long double x, long double *ip); # define Perl_modf(x,y) Perl_my_modfl(x,y) # endif # endif -# ifdef HAS_FREXPL -# define Perl_frexp(x,y) frexpl(x,y) -# else -# if defined(HAS_ILOGBL) && defined(HAS_SCALBNL) - extern long double Perl_my_frexpl(long double x, int *e); -# define Perl_frexp(x,y) Perl_my_frexpl(x,y) +# ifndef Perl_frexp +# ifdef HAS_FREXPL +# define Perl_frexp(x,y) frexpl(x,y) +# else +# if defined(HAS_ILOGBL) && defined(HAS_SCALBNL) +extern long double Perl_my_frexpl(long double x, int *e); +# define Perl_frexp(x,y) Perl_my_frexpl(x,y) +# endif +# endif +# endif +# ifndef Perl_ldexp +# ifdef HAS_LDEXPL +# define Perl_ldexp(x, y) ldexpl(x,y) +# else +# if defined(HAS_SCALBNL) && FLT_RADIX == 2 +# define Perl_ldexp(x,y) scalbnl(x,y) +# endif # endif # endif # ifndef Perl_isnan -# ifdef HAS_ISNANL +# if defined(HAS_ISNANL) && !(defined(isnan) && defined(HAS_C99)) # define Perl_isnan(x) isnanl(x) # endif # endif # ifndef Perl_isinf -# ifdef HAS_FINITEL -# define Perl_isinf(x) !(finitel(x)||Perl_isnan(x)) +# if defined(HAS_ISINFL) && !(defined(isinf) && defined(HAS_C99)) +# define Perl_isinf(x) isinfl(x) +# elif defined(LDBL_MAX) +# define Perl_isinf(x) ((x) > LDBL_MAX || (x) < -LDBL_MAX) # endif # endif +# ifndef Perl_isfinite +# define Perl_isfinite(x) Perl_isfinitel(x) +# endif #else # define NV_DIG DBL_DIG # ifdef DBL_MANT_DIG @@ -1853,6 +2010,12 @@ EXTERN_C long double modfl(long double, long double *); # ifdef DBL_MAX # define NV_MAX DBL_MAX # endif +# ifdef DBL_MIN_EXP +# define NV_MIN_EXP DBL_MIN_EXP +# endif +# ifdef DBL_MAX_EXP +# define NV_MAX_EXP DBL_MAX_EXP +# endif # ifdef DBL_MIN_10_EXP # define NV_MIN_10_EXP DBL_MIN_10_EXP # endif @@ -1870,30 +2033,121 @@ EXTERN_C long double modfl(long double, long double *); # define NV_MAX HUGE_VAL # endif # endif + +/* These math interfaces are C89. */ +# define Perl_acos acos +# define Perl_asin asin +# define Perl_atan atan +# define Perl_atan2 atan2 +# define Perl_ceil ceil # define Perl_cos cos -# define Perl_sin sin -# define Perl_sqrt sqrt +# define Perl_cosh cosh # define Perl_exp exp -# define Perl_log log -# define Perl_atan2 atan2 -# define Perl_pow pow +/* no Perl_fabs, but there's PERL_ABS */ # define Perl_floor floor -# define Perl_ceil ceil # define Perl_fmod fmod +# define Perl_log log +# define Perl_log10 log10 +# define Perl_pow pow +# define Perl_sin sin +# define Perl_sinh sinh +# define Perl_sqrt sqrt +# define Perl_tan tan +# define Perl_tanh tanh + # define Perl_modf(x,y) modf(x,y) # define Perl_frexp(x,y) frexp(x,y) +# define Perl_ldexp(x,y) ldexp(x,y) + +# ifndef Perl_isnan +# ifdef HAS_ISNAN +# define Perl_isnan(x) isnan(x) +# endif +# endif +# ifndef Perl_isinf +# if defined(HAS_ISINF) +# define Perl_isinf(x) isinf(x) +# elif defined(DBL_MAX) +# define Perl_isinf(x) ((x) > DBL_MAX || (x) < -DBL_MAX) +# endif +# endif +# ifndef Perl_isfinite +# ifdef HAS_ISFINITE +# define Perl_isfinite(x) isfinite(x) +# elif defined(HAS_FINITE) +# define Perl_isfinite(x) finite(x) +# endif +# endif +#endif + +/* fpclassify(): C99. It is supposed to be a macro that switches on +* the sizeof() of its argument, so there's no need for e.g. fpclassifyl().*/ +#if !defined(Perl_fp_class) && defined(HAS_FPCLASSIFY) +# include +# if defined(FP_INFINITE) && defined(FP_NAN) +# define Perl_fp_class(x) fpclassify(x) +# define Perl_fp_class_inf(x) (Perl_fp_class(x)==FP_INFINITE) +# define Perl_fp_class_nan(x) (Perl_fp_class(x)==FP_NAN) +# define Perl_fp_class_norm(x) (Perl_fp_class(x)==FP_NORMAL) +# define Perl_fp_class_denorm(x) (Perl_fp_class(x)==FP_SUBNORMAL) +# define Perl_fp_class_zero(x) (Perl_fp_class(x)==FP_ZERO) +# elif defined(FP_PLUS_INF) && defined(FP_QNAN) +/* Some versions of HP-UX (10.20) have (only) fpclassify() but which is + * actually not the C99 fpclassify, with its own set of return defines. */ +# define Perl_fp_class(x) fpclassify(x) +# define Perl_fp_class_pinf(x) (Perl_fp_class(x)==FP_PLUS_INF) +# define Perl_fp_class_ninf(x) (Perl_fp_class(x)==FP_MINUS_INF) +# define Perl_fp_class_snan(x) (Perl_fp_class(x)==FP_SNAN) +# define Perl_fp_class_qnan(x) (Perl_fp_class(x)==FP_QNAN) +# define Perl_fp_class_pnorm(x) (Perl_fp_class(x)==FP_PLUS_NORM) +# define Perl_fp_class_nnorm(x) (Perl_fp_class(x)==FP_MINUS_NORM) +# define Perl_fp_class_pdenorm(x) (Perl_fp_class(x)==FP_PLUS_DENORM) +# define Perl_fp_class_ndenorm(x) (Perl_fp_class(x)==FP_MINUS_DENORM) +# define Perl_fp_class_pzero(x) (Perl_fp_class(x)==FP_PLUS_ZERO) +# define Perl_fp_class_nzero(x) (Perl_fp_class(x)==FP_MINUS_ZERO) +# else +# undef Perl_fp_class /* Unknown set of defines */ +# endif #endif -/* rumor has it that Win32 has _fpclass() */ +/* fp_classify(): Legacy: VMS, maybe Unicos? The values, however, + * are identical to the C99 fpclassify(). */ +#if !defined(Perl_fp_class) && defined(HAS_FP_CLASSIFY) +# include +# ifdef __VMS + /* FP_INFINITE and others are here rather than in math.h as C99 stipulates */ +# include + /* oh, and the isnormal macro has a typo in it! */ +# undef isnormal +# define isnormal(x) Perl_fp_class_norm(x) +# endif +# if defined(FP_INFINITE) && defined(FP_NAN) +# define Perl_fp_class(x) fp_classify(x) +# define Perl_fp_class_inf(x) (Perl_fp_class(x)==FP_INFINITE) +# define Perl_fp_class_nan(x) (Perl_fp_class(x)==FP_NAN) +# define Perl_fp_class_norm(x) (Perl_fp_class(x)==FP_NORMAL) +# define Perl_fp_class_denorm(x) (Perl_fp_class(x)==FP_SUBNORMAL) +# define Perl_fp_class_zero(x) (Perl_fp_class(x)==FP_ZERO) +# else +# undef Perl_fp_class /* Unknown set of defines */ +# endif +#endif -/* SGI has fpclassl... but not with the same result values, - * and it's via a typedef (not via #define), so will need to redo Configure - * to use. Not worth the trouble, IMO, at least until the below is used - * more places. Also has fp_class_l, BTW, via fp_class.h. Feel free to check - * with me for the SGI manpages, SGI testing, etcetera, if you want to - * try getting this to work with IRIX. - Allen */ +/* Feel free to check with me for the SGI manpages, SGI testing, + * etcetera, if you want to try getting this to work with IRIX. + * + * - Allen */ +/* fpclass(): SysV, at least Solaris and some versions of IRIX. */ #if !defined(Perl_fp_class) && (defined(HAS_FPCLASS)||defined(HAS_FPCLASSL)) +/* Solaris and IRIX have fpclass/fpclassl, but they are using + * an enum typedef, not cpp symbols, and Configure doesn't detect that. + * Define some symbols also as cpp symbols so we can detect them. */ +# if defined(__sun) || defined(__irix__) /* XXX Configure test instead */ +# define FP_PINF FP_PINF +# define FP_QNAN FP_QNAN +# endif +# include # ifdef I_IEEFP # include # endif @@ -1901,134 +2155,221 @@ EXTERN_C long double modfl(long double, long double *); # include # endif # if defined(USE_LONG_DOUBLE) && defined(HAS_FPCLASSL) -# define Perl_fp_class() fpclassl(x) +# define Perl_fp_class(x) fpclassl(x) # else -# define Perl_fp_class() fpclass(x) +# define Perl_fp_class(x) fpclass(x) # endif -# define Perl_fp_class_snan(x) (Perl_fp_class(x)==FP_CLASS_SNAN) -# define Perl_fp_class_qnan(x) (Perl_fp_class(x)==FP_CLASS_QNAN) -# define Perl_fp_class_nan(x) (Perl_fp_class(x)==FP_CLASS_SNAN||Perl_fp_class(x)==FP_CLASS_QNAN) -# define Perl_fp_class_ninf(x) (Perl_fp_class(x)==FP_CLASS_NINF) -# define Perl_fp_class_pinf(x) (Perl_fp_class(x)==FP_CLASS_PINF) -# define Perl_fp_class_inf(x) (Perl_fp_class(x)==FP_CLASS_NINF||Perl_fp_class(x)==FP_CLASS_PINF) -# define Perl_fp_class_nnorm(x) (Perl_fp_class(x)==FP_CLASS_NNORM) -# define Perl_fp_class_pnorm(x) (Perl_fp_class(x)==FP_CLASS_PNORM) -# define Perl_fp_class_norm(x) (Perl_fp_class(x)==FP_CLASS_NNORM||Perl_fp_class(x)==FP_CLASS_PNORM) -# define Perl_fp_class_ndenorm(x) (Perl_fp_class(x)==FP_CLASS_NDENORM) -# define Perl_fp_class_pdenorm(x) (Perl_fp_class(x)==FP_CLASS_PDENORM) -# define Perl_fp_class_denorm(x) (Perl_fp_class(x)==FP_CLASS_NDENORM||Perl_fp_class(x)==FP_CLASS_PDENORM) -# define Perl_fp_class_nzero(x) (Perl_fp_class(x)==FP_CLASS_NZERO) -# define Perl_fp_class_pzero(x) (Perl_fp_class(x)==FP_CLASS_PZERO) -# define Perl_fp_class_zero(x) (Perl_fp_class(x)==FP_CLASS_NZERO||Perl_fp_class(x)==FP_CLASS_PZERO) -#endif - -#if !defined(Perl_fp_class) && defined(HAS_FP_CLASS) -# include -# if !defined(FP_SNAN) && defined(I_FP_CLASS) -# include +# if defined(FP_CLASS_PINF) && defined(FP_CLASS_SNAN) +# define Perl_fp_class_snan(x) (Perl_fp_class(x)==FP_CLASS_SNAN) +# define Perl_fp_class_qnan(x) (Perl_fp_class(x)==FP_CLASS_QNAN) +# define Perl_fp_class_ninf(x) (Perl_fp_class(x)==FP_CLASS_NINF) +# define Perl_fp_class_pinf(x) (Perl_fp_class(x)==FP_CLASS_PINF) +# define Perl_fp_class_nnorm(x) (Perl_fp_class(x)==FP_CLASS_NNORM) +# define Perl_fp_class_pnorm(x) (Perl_fp_class(x)==FP_CLASS_PNORM) +# define Perl_fp_class_ndenorm(x) (Perl_fp_class(x)==FP_CLASS_NDENORM) +# define Perl_fp_class_pdenorm(x) (Perl_fp_class(x)==FP_CLASS_PDENORM) +# define Perl_fp_class_nzero(x) (Perl_fp_class(x)==FP_CLASS_NZERO) +# define Perl_fp_class_pzero(x) (Perl_fp_class(x)==FP_CLASS_PZERO) +# elif defined(FP_PINF) && defined(FP_QNAN) +# define Perl_fp_class_snan(x) (Perl_fp_class(x)==FP_SNAN) +# define Perl_fp_class_qnan(x) (Perl_fp_class(x)==FP_QNAN) +# define Perl_fp_class_ninf(x) (Perl_fp_class(x)==FP_NINF) +# define Perl_fp_class_pinf(x) (Perl_fp_class(x)==FP_PINF) +# define Perl_fp_class_nnorm(x) (Perl_fp_class(x)==FP_NNORM) +# define Perl_fp_class_pnorm(x) (Perl_fp_class(x)==FP_PNORM) +# define Perl_fp_class_ndenorm(x) (Perl_fp_class(x)==FP_NDENORM) +# define Perl_fp_class_pdenorm(x) (Perl_fp_class(x)==FP_PDENORM) +# define Perl_fp_class_nzero(x) (Perl_fp_class(x)==FP_NZERO) +# define Perl_fp_class_pzero(x) (Perl_fp_class(x)==FP_PZERO) +# else +# undef Perl_fp_class /* Unknown set of defines */ # endif -# define Perl_fp_class(x) fp_class(x) -# define Perl_fp_class_snan(x) (fp_class(x)==FP_SNAN) -# define Perl_fp_class_qnan(x) (fp_class(x)==FP_QNAN) -# define Perl_fp_class_nan(x) (fp_class(x)==FP_SNAN||fp_class(x)==FP_QNAN) -# define Perl_fp_class_ninf(x) (fp_class(x)==FP_NEG_INF) -# define Perl_fp_class_pinf(x) (fp_class(x)==FP_POS_INF) -# define Perl_fp_class_inf(x) (fp_class(x)==FP_NEG_INF||fp_class(x)==FP_POS_INF) -# define Perl_fp_class_nnorm(x) (fp_class(x)==FP_NEG_NORM) -# define Perl_fp_class_pnorm(x) (fp_class(x)==FP_POS_NORM) -# define Perl_fp_class_norm(x) (fp_class(x)==FP_NEG_NORM||fp_class(x)==FP_POS_NORM) -# define Perl_fp_class_ndenorm(x) (fp_class(x)==FP_NEG_DENORM) -# define Perl_fp_class_pdenorm(x) (fp_class(x)==FP_POS_DENORM) -# define Perl_fp_class_denorm(x) (fp_class(x)==FP_NEG_DENORM||fp_class(x)==FP_POS_DENORM) -# define Perl_fp_class_nzero(x) (fp_class(x)==FP_NEG_ZERO) -# define Perl_fp_class_pzero(x) (fp_class(x)==FP_POS_ZERO) -# define Perl_fp_class_zero(x) (fp_class(x)==FP_NEG_ZERO||fp_class(x)==FP_POS_ZERO) #endif -#if !defined(Perl_fp_class) && defined(HAS_FPCLASSIFY) +/* fp_class(): Legacy: at least Tru64, some versions of IRIX. */ +#if !defined(Perl_fp_class) && (defined(HAS_FP_CLASS)||defined(HAS_FP_CLASSL)) # include -# define Perl_fp_class(x) fpclassify(x) -# define Perl_fp_class_nan(x) (fp_classify(x)==FP_SNAN||fp_classify(x)==FP_QNAN) -# define Perl_fp_class_inf(x) (fp_classify(x)==FP_INFINITE) -# define Perl_fp_class_norm(x) (fp_classify(x)==FP_NORMAL) -# define Perl_fp_class_denorm(x) (fp_classify(x)==FP_SUBNORMAL) -# define Perl_fp_class_zero(x) (fp_classify(x)==FP_ZERO) +# if !defined(FP_SNAN) && defined(I_FP_CLASS) +# include +# endif +# if defined(FP_POS_INF) && defined(FP_QNAN) +# ifdef __irix__ /* XXX Configure test instead */ +# ifdef USE_LONG_DOUBLE +# define Perl_fp_class(x) fp_class_l(x) +# else +# define Perl_fp_class(x) fp_class_d(x) +# endif +# else +# if defined(USE_LONG_DOUBLE) && defined(HAS_FP_CLASSL) +# define Perl_fp_class(x) fp_classl(x) +# else +# define Perl_fp_class(x) fp_class(x) +# endif +# endif +# if defined(FP_POS_INF) && defined(FP_QNAN) +# define Perl_fp_class_snan(x) (Perl_fp_class(x)==FP_SNAN) +# define Perl_fp_class_qnan(x) (Perl_fp_class(x)==FP_QNAN) +# define Perl_fp_class_ninf(x) (Perl_fp_class(x)==FP_NEG_INF) +# define Perl_fp_class_pinf(x) (Perl_fp_class(x)==FP_POS_INF) +# define Perl_fp_class_nnorm(x) (Perl_fp_class(x)==FP_NEG_NORM) +# define Perl_fp_class_pnorm(x) (Perl_fp_class(x)==FP_POS_NORM) +# define Perl_fp_class_ndenorm(x) (Perl_fp_class(x)==FP_NEG_DENORM) +# define Perl_fp_class_pdenorm(x) (Perl_fp_class(x)==FP_POS_DENORM) +# define Perl_fp_class_nzero(x) (Perl_fp_class(x)==FP_NEG_ZERO) +# define Perl_fp_class_pzero(x) (Perl_fp_class(x)==FP_POS_ZERO) +# else +# undef Perl_fp_class /* Unknown set of defines */ +# endif +# endif #endif +/* class(), _class(): Legacy: AIX. */ #if !defined(Perl_fp_class) && defined(HAS_CLASS) # include -# ifndef _cplusplus -# define Perl_fp_class(x) class(x) -# else -# define Perl_fp_class(x) _class(x) +# if defined(FP_PLUS_NORM) && defined(FP_PLUS_INF) +# ifndef _cplusplus +# define Perl_fp_class(x) class(x) +# else +# define Perl_fp_class(x) _class(x) +# endif +# if defined(FP_PLUS_INF) && defined(FP_NANQ) +# define Perl_fp_class_snan(x) (Perl_fp_class(x)==FP_NANS) +# define Perl_fp_class_qnan(x) (Perl_fp_class(x)==FP_NANQ) +# define Perl_fp_class_ninf(x) (Perl_fp_class(x)==FP_MINUS_INF) +# define Perl_fp_class_pinf(x) (Perl_fp_class(x)==FP_PLUS_INF) +# define Perl_fp_class_nnorm(x) (Perl_fp_class(x)==FP_MINUS_NORM) +# define Perl_fp_class_pnorm(x) (Perl_fp_class(x)==FP_PLUS_NORM) +# define Perl_fp_class_ndenorm(x) (Perl_fp_class(x)==FP_MINUS_DENORM) +# define Perl_fp_class_pdenorm(x) (Perl_fp_class(x)==FP_PLUS_DENORM) +# define Perl_fp_class_nzero(x) (Perl_fp_class(x)==FP_MINUS_ZERO) +# define Perl_fp_class_pzero(x) (Perl_fp_class(x)==FP_PLUS_ZERO) +# else +# undef Perl_fp_class /* Unknown set of defines */ +# endif # endif -# define Perl_fp_class_snan(x) (Perl_fp_class(x)==FP_NANS) -# define Perl_fp_class_qnan(x) (Perl_fp_class(x)==FP_NANQ) -# define Perl_fp_class_nan(x) (Perl_fp_class(x)==FP_SNAN||Perl_fp_class(x)==FP_QNAN) -# define Perl_fp_class_ninf(x) (Perl_fp_class(x)==FP_MINUS_INF) -# define Perl_fp_class_pinf(x) (Perl_fp_class(x)==FP_PLUS_INF) -# define Perl_fp_class_inf(x) (Perl_fp_class(x)==FP_MINUS_INF||Perl_fp_class(x)==FP_PLUS_INF) -# define Perl_fp_class_nnorm(x) (Perl_fp_class(x)==FP_MINUS_NORM) -# define Perl_fp_class_pnorm(x) (Perl_fp_class(x)==FP_PLUS_NORM) -# define Perl_fp_class_norm(x) (Perl_fp_class(x)==FP_MINUS_NORM||Perl_fp_class(x)==FP_PLUS_NORM) -# define Perl_fp_class_ndenorm(x) (Perl_fp_class(x)==FP_MINUS_DENORM) -# define Perl_fp_class_pdenorm(x) (Perl_fp_class(x)==FP_PLUS_DENORM) -# define Perl_fp_class_denorm(x) (Perl_fp_class(x)==FP_MINUS_DENORM||Perl_fp_class(x)==FP_PLUS_DENORM) -# define Perl_fp_class_nzero(x) (Perl_fp_class(x)==FP_MINUS_ZERO) -# define Perl_fp_class_pzero(x) (Perl_fp_class(x)==FP_PLUS_ZERO) -# define Perl_fp_class_zero(x) (Perl_fp_class(x)==FP_MINUS_ZERO||Perl_fp_class(x)==FP_PLUS_ZERO) -#endif - -/* rumor has it that Win32 has _isnan() */ +#endif -#ifndef Perl_isnan -# ifdef HAS_ISNAN -# define Perl_isnan(x) isnan((NV)x) -# else -# ifdef Perl_fp_class_nan -# define Perl_isnan(x) Perl_fp_class_nan(x) -# else -# ifdef HAS_UNORDERED -# define Perl_isnan(x) unordered((x), 0.0) -# else -# define Perl_isnan(x) ((x)!=(x)) -# endif -# endif -# endif +/* Win32: _fpclass(), _isnan(), _finite(). */ +#ifdef WIN32 +# ifndef Perl_isnan +# define Perl_isnan(x) _isnan(x) +# endif +# ifndef Perl_isfinite +# define Perl_isfinite(x) _finite(x) +# endif +# ifndef Perl_fp_class_snan +/* No simple way to #define Perl_fp_class because _fpclass() + * returns a set of bits. */ +# define Perl_fp_class_snan(x) (_fpclass(x) & _FPCLASS_SNAN) +# define Perl_fp_class_qnan(x) (_fpclass(x) & _FPCLASS_QNAN) +# define Perl_fp_class_nan(x) (_fpclass(x) & (_FPCLASS_SNAN|_FPCLASS_QNAN)) +# define Perl_fp_class_ninf(x) (_fpclass(x) & _FPCLASS_NINF)) +# define Perl_fp_class_pinf(x) (_fpclass(x) & _FPCLASS_PINF)) +# define Perl_fp_class_inf(x) (_fpclass(x) & (_FPCLASS_NINF|_FPCLASS_PINF)) +# define Perl_fp_class_nnorm(x) (_fpclass(x) & _FPCLASS_NN) +# define Perl_fp_class_pnorm(x) (_fpclass(x) & _FPCLASS_PN) +# define Perl_fp_class_norm(x) (_fpclass(x) & (_FPCLASS_NN|_FPCLASS_PN)) +# define Perl_fp_class_ndenorm(x) (_fpclass(x) & _FPCLASS_ND) +# define Perl_fp_class_pdenorm(x) (_fpclass(x) & _FPCLASS_PD) +# define Perl_fp_class_denorm(x) (_fpclass(x) & (_FPCLASS_ND|_FPCLASS_PD)) +# define Perl_fp_class_nzero(x) (_fpclass(x) & _FPCLASS_NZ) +# define Perl_fp_class_pzero(x) (_fpclass(x) & _FPCLASS_PZ) +# define Perl_fp_class_zero(x) (_fpclass(x) & (_FPCLASS_NZ|_FPCLASS_PZ)) +# endif +#endif + +#if !defined(Perl_fp_class_inf) && \ + defined(Perl_fp_class_pinf) && defined(Perl_fp_class_ninf) +# define Perl_fp_class_inf(x) \ + (Perl_fp_class_pinf(x) || Perl_fp_class_ninf(x)) +#endif + +#if !defined(Perl_fp_class_nan) && \ + defined(Perl_fp_class_snan) && defined(Perl_fp_class_qnan) +# define Perl_fp_class_nan(x) \ + (Perl_fp_class_snan(x) || Perl_fp_class_qnan(x)) +#endif + +#if !defined(Perl_fp_class_zero) && \ + defined(Perl_fp_class_pzero) && defined(Perl_fp_class_nzero) +# define Perl_fp_class_zero(x) \ + (Perl_fp_class_pzero(x) || Perl_fp_class_nzero(x)) +#endif + +#if !defined(Perl_fp_class_norm) && \ + defined(Perl_fp_class_pnorm) && defined(Perl_fp_class_nnorm) +# define Perl_fp_class_norm(x) \ + (Perl_fp_class_pnorm(x) || Perl_fp_class_nnorm(x)) +#endif + +#if !defined(Perl_fp_class_denorm) && \ + defined(Perl_fp_class_pdenorm) && defined(Perl_fp_class_ndenorm) +# define Perl_fp_class_denorm(x) \ + (Perl_fp_class_pdenorm(x) || Perl_fp_class_ndenorm(x)) #endif #ifdef UNDER_CE int isnan(double d); #endif -#ifndef Perl_isinf -# ifdef HAS_ISINF -# define Perl_isinf(x) isinf((NV)x) +#ifndef Perl_isnan +# ifdef Perl_fp_class_nan +# define Perl_isnan(x) Perl_fp_class_nan(x) # else -# ifdef Perl_fp_class_inf -# define Perl_isinf(x) Perl_fp_class_inf(x) +# ifdef HAS_UNORDERED +# define Perl_isnan(x) unordered((x), 0.0) # else -# define Perl_isinf(x) ((x)==NV_INF) +# define Perl_isnan(x) ((x)!=(x)) # endif # endif #endif +#ifndef Perl_isinf +# ifdef Perl_fp_class_inf +# define Perl_isinf(x) Perl_fp_class_inf(x) +# endif +#endif + #ifndef Perl_isfinite -# ifdef HAS_FINITE -# define Perl_isfinite(x) finite((NV)x) +# if defined(HAS_ISFINITE) && !defined(isfinite) +# define Perl_isfinite(x) isfinite((double)(x)) +# elif defined(HAS_FINITE) +# define Perl_isfinite(x) finite((double)(x)) +# elif defined(Perl_fp_class_finite) +# define Perl_isfinite(x) Perl_fp_class_finite(x) # else -# ifdef HAS_ISFINITE -# define Perl_isfinite(x) isfinite(x) -# else -# ifdef Perl_fp_class_finite -# define Perl_isfinite(x) Perl_fp_class_finite(x) -# else -# define Perl_isfinite(x) !(Perl_is_inf(x)||Perl_is_nan(x)) -# endif -# endif +/* For the infinities the multiplication returns nan, + * for the nan the multiplication also returns nan, + * for everything else (that is, finite) zero should be returned. */ +# define Perl_isfinite(x) (((x) * 0) == 0) +# endif +#endif + +#ifndef Perl_isinf +# if defined(Perl_isfinite) && defined(Perl_isnan) +# define Perl_isinf(x) !(Perl_isfinite(x)||Perl_isnan(x)) # endif #endif +/* We need Perl_isfinitel (ends with ell) (if available) even when + * not USE_LONG_DOUBLE because the printf code (sv_catpvfn_flags) + * needs that. */ +#if defined(HAS_LONG_DOUBLE) && !defined(Perl_isfinitel) +/* If isfinite() is a macro and looks like we have C99, + * we assume it's the type-aware C99 isfinite(). */ +# if defined(HAS_ISFINITE) && defined(isfinite) && defined(HAS_C99) +# define Perl_isfinitel(x) isfinite(x) +# elif defined(HAS_ISFINITEL) +# define Perl_isfinitel(x) isfinitel(x) +# elif defined(HAS_FINITEL) +# define Perl_isfinitel(x) finitel(x) +# elif defined(HAS_INFL) && defined(HAS_NANL) +# define Perl_isfinitel(x) !(isinfl(x)||isnanl(x)) +# else +# define Perl_isfinitel(x) ((x) * 0 == 0) /* See Perl_isfinite. */ +# endif +#endif + /* The default is to use Perl's own atof() implementation (in numeric.c). * Usually that is the one to use but for some platforms (e.g. UNICOS) * it is however best to use the native implementation of atof. @@ -2233,11 +2574,6 @@ int isnan(double d); typedef MEM_SIZE STRLEN; -#ifdef PERL_MAD -typedef struct token TOKEN; -typedef struct madprop MADPROP; -typedef struct nexttoken NEXTTOKE; -#endif typedef struct op OP; typedef struct cop COP; typedef struct unop UNOP; @@ -2546,6 +2882,8 @@ typedef SV PADNAME; #endif /* +=head1 Miscellaneous Functions + =for apidoc Am|void|PERL_SYS_INIT|int *argc|char*** argv Provides system-specific tune up of the C runtime environment necessary to run Perl interpreters. This should be called only once, before creating @@ -2660,9 +2998,6 @@ freeing any remaining Perl interpreters. # else # ifdef I_MACH_CTHREADS # include -# if (defined(NeXT) || defined(__NeXT__)) && defined(PERL_POLLUTE_MALLOC) -# define MUTEX_INIT_CALLS_MALLOC -# endif typedef cthread_t perl_os_thread; typedef mutex_t perl_mutex; typedef condition_t perl_cond; @@ -3029,7 +3364,7 @@ typedef pthread_key_t perl_key; /* Takes three arguments: is_utf8, length, str */ #ifndef UTF8f -# define UTF8f "d%"UVuf"%4p" +# define UTF8f "d%" UVuf "%4p" #endif #define UTF8fARG(u,l,p) (int)cBOOL(u), (UV)(l), (void*)(p) @@ -3093,6 +3428,10 @@ typedef pthread_key_t perl_key; # define __attribute__warn_unused_result__ #endif +#if defined(DEBUGGING) && defined(I_ASSERT) +# include +#endif + /* For functions that are marked as __attribute__noreturn__, it's not appropriate to call return. In either case, include the lint directive. */ @@ -3221,7 +3560,7 @@ typedef I32 (*filter_t) (pTHX_ int, SV *, int); && idx >= AvFILLp(PL_parser->rsfp_filters)) #define PERL_FILTER_EXISTS(i) \ (PL_parser && PL_parser->rsfp_filters \ - && (i) <= av_len(PL_parser->rsfp_filters)) + && (i) <= av_tindex(PL_parser->rsfp_filters)) #if defined(_AIX) && !defined(_AIX43) #if defined(USE_REENTRANT) || defined(_REENTRANT) || defined(_THREAD_SAFE) @@ -3268,13 +3607,6 @@ typedef struct crypt_data { /* straight from /usr/include/crypt.h */ #endif #include "perly.h" -#ifdef PERL_MAD -struct nexttoken { - YYSTYPE next_val; /* value of next token, if any */ - I32 next_type; /* type of next token */ - MADPROP *next_mad; /* everything else about that token */ -}; -#endif /* macros to define bit-fields in structs. */ #ifndef PERL_BITFIELD8 @@ -3331,6 +3663,8 @@ typedef struct magic_state MGS; /* struct magic_state defined in mg.c */ * before their definitions in regcomp.h. */ struct scan_data_t; +typedef struct regnode_charclass regnode_charclass; + struct regnode_charclass_class; /* A hopefully less confusing name. The sub-classes are all Posix classes only @@ -3484,11 +3818,11 @@ my_swap16(const U16 x) { #define U_32(n) ((n) < 0.0 ? ((n) < I32_MIN ? (UV) I32_MIN : (U32)(I32) (n)) \ : ((n) < U32_MAX_P1 ? (U32) (n) \ : ((n) > 0 ? U32_MAX : 0 /* NaN */))) -#define I_V(n) ((n) < IV_MAX_P1 ? ((n) < IV_MIN ? IV_MIN : (IV) (n)) \ - : ((n) < UV_MAX_P1 ? (IV)(UV) (n) \ +#define I_V(n) (LIKELY((n) < IV_MAX_P1) ? (UNLIKELY((n) < IV_MIN) ? IV_MIN : (IV) (n)) \ + : (LIKELY((n) < UV_MAX_P1) ? (IV)(UV) (n) \ : ((n) > 0 ? (IV)UV_MAX : 0 /* NaN */))) -#define U_V(n) ((n) < 0.0 ? ((n) < IV_MIN ? (UV) IV_MIN : (UV)(IV) (n)) \ - : ((n) < UV_MAX_P1 ? (UV) (n) \ +#define U_V(n) ((n) < 0.0 ? (UNLIKELY((n) < IV_MIN) ? (UV) IV_MIN : (UV)(IV) (n)) \ + : (LIKELY((n) < UV_MAX_P1) ? (UV) (n) \ : ((n) > 0 ? UV_MAX : 0 /* NaN */))) #endif @@ -3563,7 +3897,8 @@ Gid_t getegid (void); #define DEBUG_q_FLAG 0x00800000 /*8388608 */ #define DEBUG_M_FLAG 0x01000000 /*16777216*/ #define DEBUG_B_FLAG 0x02000000 /*33554432*/ -#define DEBUG_MASK 0x03FFEFFF /* mask of all the standard flags */ +#define DEBUG_L_FLAG 0x04000000 /*67108864*/ +#define DEBUG_MASK 0x07FFEFFF /* mask of all the standard flags */ #define DEBUG_DB_RECURSE_FLAG 0x40000000 #define DEBUG_TOP_FLAG 0x80000000 /* XXX what's this for ??? Signal @@ -3595,6 +3930,7 @@ Gid_t getegid (void); # define DEBUG_q_TEST_ (PL_debug & DEBUG_q_FLAG) # define DEBUG_M_TEST_ (PL_debug & DEBUG_M_FLAG) # define DEBUG_B_TEST_ (PL_debug & DEBUG_B_FLAG) +# define DEBUG_L_TEST_ (PL_debug & DEBUG_L_FLAG) # define DEBUG_Xv_TEST_ (DEBUG_X_TEST_ && DEBUG_v_TEST_) # define DEBUG_Uv_TEST_ (DEBUG_U_TEST_ && DEBUG_v_TEST_) # define DEBUG_Pv_TEST_ (DEBUG_P_TEST_ && DEBUG_v_TEST_) @@ -3627,6 +3963,7 @@ Gid_t getegid (void); # define DEBUG_q_TEST DEBUG_q_TEST_ # define DEBUG_M_TEST DEBUG_M_TEST_ # define DEBUG_B_TEST DEBUG_B_TEST_ +# define DEBUG_L_TEST DEBUG_L_TEST_ # define DEBUG_Xv_TEST DEBUG_Xv_TEST_ # define DEBUG_Uv_TEST DEBUG_Uv_TEST_ # define DEBUG_Pv_TEST DEBUG_Pv_TEST_ @@ -3678,6 +4015,7 @@ Gid_t getegid (void); # define DEBUG_q(a) DEBUG__(DEBUG_q_TEST, a) # define DEBUG_M(a) DEBUG__(DEBUG_M_TEST, a) # define DEBUG_B(a) DEBUG__(DEBUG_B_TEST, a) +# define DEBUG_L(a) DEBUG__(DEBUG_L_TEST, a) #else /* DEBUGGING */ @@ -3707,6 +4045,7 @@ Gid_t getegid (void); # define DEBUG_q_TEST (0) # define DEBUG_M_TEST (0) # define DEBUG_B_TEST (0) +# define DEBUG_L_TEST (0) # define DEBUG_Xv_TEST (0) # define DEBUG_Uv_TEST (0) # define DEBUG_Pv_TEST (0) @@ -3738,6 +4077,7 @@ Gid_t getegid (void); # define DEBUG_q(a) # define DEBUG_M(a) # define DEBUG_B(a) +# define DEBUG_L(a) # define DEBUG_Xv(a) # define DEBUG_Uv(a) # define DEBUG_Pv(a) @@ -3750,10 +4090,6 @@ Gid_t getegid (void); where, (long)PL_scopestack_ix, (long)PL_savestack_ix, \ __FILE__, __LINE__)); -#if defined(DEBUGGING) && defined(I_ASSERT) -# include -#endif - /* Keep the old croak based assert for those who want it, and as a fallback if the platform is so heretically non-ANSI that it can't assert. */ @@ -3763,6 +4099,8 @@ Gid_t getegid (void); "\", line %d", STRINGIFY(what), __LINE__), \ (void) 0))) +/* assert() gets defined if DEBUGGING (and I_ASSERT). + * If no DEBUGGING, the has not been included. */ #ifndef assert # define assert(what) Perl_assert(what) #endif @@ -3824,6 +4162,10 @@ char *strcpy(), *strcat(); #ifdef I_MATH # include +# ifdef __VMS + /* isfinite and others are here rather than in math.h as C99 stipulates */ +# include +# endif #else START_EXTERN_C double exp (double); @@ -3840,8 +4182,27 @@ START_EXTERN_C END_EXTERN_C #endif -#if !defined(NV_INF) && defined(USE_LONG_DOUBLE) && defined(LDBL_INFINITY) -# define NV_INF LDBL_INFINITY +#ifdef WIN32 +# if !defined(NV_INF) && defined(HUGE_VAL) +# define NV_INF HUGE_VAL +# endif +/* For WIN32 the best NV_NAN is the __PL_nan_u trick, see below. + * There is no supported way of getting the NAN across all the crts. */ +#endif + +/* If you are thinking of using HUGE_VAL for infinity, or using + * functions to generate NV_INF (e.g. exp(1e9), log(-1.0)), + * stop. Neither will work portably: HUGE_VAL can be just DBL_MAX, + * and the math functions might be just generating DBL_MAX, or even + * zero. */ + +#if !defined(NV_INF) && defined(USE_LONG_DOUBLE) +# if !defined(NV_INF) && defined(LDBL_INFINITY) +# define NV_INF LDBL_INFINITY +# endif +# if !defined(NV_INF) && defined(INFINITYL) +# define NV_INF INFINITYL +# endif #endif #if !defined(NV_INF) && defined(DBL_INFINITY) # define NV_INF (NV)DBL_INFINITY @@ -3852,17 +4213,40 @@ END_EXTERN_C #if !defined(NV_INF) && defined(INF) # define NV_INF (NV)INF #endif -#if !defined(NV_INF) && defined(USE_LONG_DOUBLE) && defined(HUGE_VALL) -# define NV_INF (NV)HUGE_VALL +#if !defined(NV_INF) +# if INTSIZE == 4 +/* At this point we assume the IEEE 754 floating point (and of course, + * we also assume a floating point format that can encode an infinity). + * We will coerce an int32 (which will encode the infinity) into + * a 32-bit float, which will then be cast into NV. + * + * Note that we intentionally use a float and 32-bit int, instead of + * shifting a small integer into a full IV, and from that into a full + * NV, because: + * + * (1) an IV might not be wide enough to cover all the bits of an NV. + * (2) the exponent part (including the infinity and nan bits) of a NV + * might be wider than just 16 bits. + * + * Below the NV_NAN logic has similar __PL_nan_u fallback, the only + * difference being the int32 constant being coerced. */ +# define __PL_inf_float_int32 0x7F800000 +static const union { unsigned int __i; float __f; } __PL_inf_u = + { __PL_inf_float_int32 }; +# define NV_INF ((NV)(__PL_inf_u.__f)) +# endif #endif -#if !defined(NV_INF) && defined(HUGE_VAL) -# define NV_INF (NV)HUGE_VAL +#if !defined(NV_INF) +# define NV_INF ((NV)1.0/0.0) /* Some compilers will warn. */ #endif #if !defined(NV_NAN) && defined(USE_LONG_DOUBLE) # if !defined(NV_NAN) && defined(LDBL_NAN) # define NV_NAN LDBL_NAN # endif +# if !defined(NV_NAN) && defined(NANL) +# define NV_NAN NANL +# endif # if !defined(NV_NAN) && defined(LDBL_QNAN) # define NV_NAN LDBL_QNAN # endif @@ -3879,26 +4263,37 @@ END_EXTERN_C #if !defined(NV_NAN) && defined(DBL_SNAN) # define NV_NAN (NV)DBL_SNAN #endif +#if !defined(NV_NAN) && defined(NAN) +# define NV_NAN (NV)NAN +#endif #if !defined(NV_NAN) && defined(QNAN) # define NV_NAN (NV)QNAN #endif #if !defined(NV_NAN) && defined(SNAN) # define NV_NAN (NV)SNAN #endif -#if !defined(NV_NAN) && defined(NAN) -# define NV_NAN (NV)NAN +#if !defined(NV_NAN) +# if INTSIZE == 4 +/* See the discussion near __PL_inf_u. */ +# define __PL_nan_float_int32 0x7FC00000 +static const union { unsigned int __i; float __f; } __PL_nan_u = + { __PL_nan_float_int32 }; +# define NV_NAN ((NV)(__PL_nan_u.__f)) +# endif +#endif +#if !defined(NV_NAN) +# define NV_NAN ((NV)0.0/0.0) /* Some compilers will warn. */ #endif +/* Do NOT try doing NV_NAN based on NV_INF and trying (NV_INF-NV_INF). + * Though IEEE-754-logically correct, some compilers (like Visual C 2003) + * falsely misoptimize that to zero (x-x is zero, right?) */ #ifndef __cplusplus -# if defined(NeXT) || defined(__NeXT__) /* or whatever catches all NeXTs */ -char *crypt (); /* Maybe more hosts will need the unprototyped version */ -# else -# if !defined(WIN32) && !defined(VMS) +# if !defined(WIN32) && !defined(VMS) #ifndef crypt char *crypt (const char*, const char*); #endif -# endif /* !WIN32 */ -# endif /* !NeXT && !__NeXT__ */ +# endif /* !WIN32 */ # ifndef DONT_DECLARE_STD # ifndef getenv char *getenv (const char*); @@ -4015,28 +4410,52 @@ EXTERN_C void PerlIO_teardown(void); struct perl_memory_debug_header; struct perl_memory_debug_header { tTHX interpreter; -# ifdef PERL_POISON +# if defined(PERL_POISON) || defined(PERL_DEBUG_READONLY_COW) MEM_SIZE size; # endif struct perl_memory_debug_header *prev; struct perl_memory_debug_header *next; +# ifdef PERL_DEBUG_READONLY_COW + bool readonly; +# endif +}; + +#elif defined(PERL_DEBUG_READONLY_COW) + +struct perl_memory_debug_header; +struct perl_memory_debug_header { + MEM_SIZE size; }; -# define sTHX (sizeof(struct perl_memory_debug_header) + \ +#endif + +#if defined (PERL_TRACK_MEMPOOL) || defined (PERL_DEBUG_READONLY_COW) + +# define PERL_MEMORY_DEBUG_HEADER_SIZE \ + (sizeof(struct perl_memory_debug_header) + \ (MEM_ALIGNBYTES - sizeof(struct perl_memory_debug_header) \ %MEM_ALIGNBYTES) % MEM_ALIGNBYTES) #else -# define sTHX 0 +# define PERL_MEMORY_DEBUG_HEADER_SIZE 0 #endif #ifdef PERL_TRACK_MEMPOOL +# ifdef PERL_DEBUG_READONLY_COW # define INIT_TRACK_MEMPOOL(header, interp) \ STMT_START { \ (header).interpreter = (interp); \ (header).prev = (header).next = &(header); \ + (header).readonly = 0; \ } STMT_END -# else +# else +# define INIT_TRACK_MEMPOOL(header, interp) \ + STMT_START { \ + (header).interpreter = (interp); \ + (header).prev = (header).next = &(header); \ + } STMT_END +# endif +# else # define INIT_TRACK_MEMPOOL(header, interp) #endif @@ -4048,10 +4467,10 @@ struct perl_memory_debug_header { #ifdef MYMALLOC # define Perl_safesysmalloc_size(where) Perl_malloced_size(where) #else -# ifdef HAS_MALLOC_SIZE +# if defined(HAS_MALLOC_SIZE) && !defined(PERL_DEBUG_READONLY_COW) # ifdef PERL_TRACK_MEMPOOL # define Perl_safesysmalloc_size(where) \ - (malloc_size(((char *)(where)) - sTHX) - sTHX) + (malloc_size(((char *)(where)) - PERL_MEMORY_DEBUG_HEADER_SIZE) - PERL_MEMORY_DEBUG_HEADER_SIZE) # else # define Perl_safesysmalloc_size(where) malloc_size(where) # endif @@ -4059,7 +4478,7 @@ struct perl_memory_debug_header { # ifdef HAS_MALLOC_GOOD_SIZE # ifdef PERL_TRACK_MEMPOOL # define Perl_malloc_good_size(how_much) \ - (malloc_good_size((how_much) + sTHX) - sTHX) + (malloc_good_size((how_much) + PERL_MEMORY_DEBUG_HEADER_SIZE) - PERL_MEMORY_DEBUG_HEADER_SIZE) # else # define Perl_malloc_good_size(how_much) malloc_good_size(how_much) # endif @@ -4076,19 +4495,9 @@ typedef OP* (*PPADDR_t[]) (pTHX); typedef bool (*destroyable_proc_t) (pTHX_ SV *sv); typedef void (*despatch_signals_proc_t) (pTHX); -/* NeXT has problems with crt0.o globals */ -#if defined(__DYNAMIC__) && \ - (defined(NeXT) || defined(__NeXT__) || defined(PERL_DARWIN)) -# if defined(NeXT) || defined(__NeXT) -# include -# define environ (*environ_pointer) -EXT char *** environ_pointer; -# else -# if defined(PERL_DARWIN) && defined(PERL_CORE) -# include /* for the env array */ -# define environ (*_NSGetEnviron()) -# endif -# endif +#if defined(__DYNAMIC__) && defined(PERL_DARWIN) && defined(PERL_CORE) +# include /* for the env array */ +# define environ (*_NSGetEnviron()) #else /* VMS and some other platforms don't use the environ array */ # ifdef USE_ENVIRON_ARRAY @@ -4118,7 +4527,7 @@ START_EXTERN_C EXTCONST char PL_warn_uninit[] INIT("Use of uninitialized value%s%s%s"); EXTCONST char PL_warn_uninit_sv[] - INIT("Use of uninitialized value%"SVf"%s%s"); + INIT("Use of uninitialized value%" SVf "%s%s"); EXTCONST char PL_warn_nosemi[] INIT("Semicolon seems to be missing"); EXTCONST char PL_warn_reserved[] @@ -4138,7 +4547,7 @@ EXTCONST char PL_no_usym[] EXTCONST char PL_no_aelem[] INIT("Modification of non-creatable array value attempted, subscript %d"); EXTCONST char PL_no_helem_sv[] - INIT("Modification of non-creatable hash value attempted, subscript \"%"SVf"\""); + INIT("Modification of non-creatable hash value attempted, subscript \"%" SVf "\""); EXTCONST char PL_no_modify[] INIT("Modification of a read-only value attempted"); EXTCONST char PL_no_mem[sizeof("Out of memory!\n")] @@ -4556,21 +4965,24 @@ EXTCONST char PL_bincompat_options[] = # ifdef PERLIO_LAYERS " PERLIO_LAYERS" # endif +# ifdef PERL_DEBUG_READONLY_COW + " PERL_DEBUG_READONLY_COW" +# endif # ifdef PERL_DEBUG_READONLY_OPS " PERL_DEBUG_READONLY_OPS" # endif # ifdef PERL_GLOBAL_STRUCT " PERL_GLOBAL_STRUCT" # endif +# ifdef PERL_GLOBAL_STRUCT_PRIVATE + " PERL_GLOBAL_STRUCT_PRIVATE" +# endif # ifdef PERL_IMPLICIT_CONTEXT " PERL_IMPLICIT_CONTEXT" # endif # ifdef PERL_IMPLICIT_SYS " PERL_IMPLICIT_SYS" # endif -# ifdef PERL_MAD - " PERL_MAD" -# endif # ifdef PERL_MICRO " PERL_MICRO" # endif @@ -4616,12 +5028,18 @@ EXTCONST char PL_bincompat_options[] = # ifdef USE_LOCALE_NUMERIC " USE_LOCALE_NUMERIC" # endif +# ifdef USE_LOCALE_TIME + " USE_LOCALE_TIME" +# endif # ifdef USE_LONG_DOUBLE " USE_LONG_DOUBLE" # endif # ifdef USE_PERLIO " USE_PERLIO" # endif +# ifdef USE_QUADMATH + " USE_QUADMATH" +# endif # ifdef USE_REENTRANT_API " USE_REENTRANT_API" # endif @@ -4713,6 +5131,7 @@ typedef enum { XATTRBLOCK, XATTRTERM, XTERMBLOCK, + XBLOCKTERM, XPOSTDEREF, XTERMORDORDOR /* evil hack */ /* update exp_name[] in toke.c if adding to this enum */ @@ -4720,12 +5139,21 @@ typedef enum { /* Hints are now stored in a dedicated U32, so the bottom 8 bits are no longer special and there is no need for HINT_PRIVATE_MASK for COPs - However, bitops store HINT_INTEGER in their op_private. */ + However, bitops store HINT_INTEGER in their op_private. + + NOTE: The typical module using these has the bit value hard-coded, so don't + blindly change the values of these. + + If we run out of bits, the 2 locale ones could be combined. The PARTIAL one + is for "use locale 'FOO'" which excludes some categories. It requires going + to %^H to find out which are in and which are out. This could be extended + for the normal case of a plain HINT_LOCALE, so that %^H would be used for + any locale form. */ #define HINT_INTEGER 0x00000001 /* integer pragma */ #define HINT_STRICT_REFS 0x00000002 /* strict pragma */ #define HINT_LOCALE 0x00000004 /* locale pragma */ #define HINT_BYTES 0x00000008 /* bytes pragma */ -#define HINT_LOCALE_NOT_CHARS 0x00000010 /* locale ':not_characters' pragma */ +#define HINT_LOCALE_PARTIAL 0x00000010 /* locale, but a subset of categories */ #define HINT_EXPLICIT_STRICT_REFS 0x00000020 /* strict.pm */ #define HINT_EXPLICIT_STRICT_SUBS 0x00000040 /* strict.pm */ @@ -4980,12 +5408,6 @@ struct tempsym; /* defined in pp_pack.c */ #if !defined(PERL_FOR_X2P) # include "embedvar.h" #endif -#ifndef PERL_MAD -# undef PL_madskills -# undef PL_xmlfp -# define PL_madskills 0 -# define PL_xmlfp 0 -#endif /* Now include all the 'global' variables * If we don't have threads or multiple interpreters @@ -5012,10 +5434,6 @@ END_EXTERN_C In particular, need the relevant *ish file included already, as it may define HAVE_INTERP_INTERN */ #include "embed.h" -#ifndef PERL_MAD -# undef op_getmad -# define op_getmad(arg,pegop,slot) NOOP -#endif #ifndef PERL_GLOBAL_STRUCT START_EXTERN_C @@ -5097,6 +5515,25 @@ EXTCONST bool PL_valid_types_NV_set[]; #endif + +/* if these never got defined, they need defaults */ +#ifndef PERL_SET_CONTEXT +# define PERL_SET_CONTEXT(i) PERL_SET_INTERP(i) +#endif + +#ifndef PERL_GET_CONTEXT +# define PERL_GET_CONTEXT PERL_GET_INTERP +#endif + +#ifndef PERL_GET_THX +# define PERL_GET_THX ((void*)NULL) +#endif + +#ifndef PERL_SET_THX +# define PERL_SET_THX(t) NOOP +#endif + + #ifndef PERL_NO_INLINE_FUNCTIONS /* Static inline funcs that depend on includes and declarations above. Some of these reference functions in the perl object files, and some @@ -5210,26 +5647,60 @@ typedef struct am_table_short AMTS; #define PERLDB_SAVESRC_NOSUBS (PL_perldb && (PL_perldb & PERLDBf_SAVESRC_NOSUBS)) #define PERLDB_SAVESRC_INVALID (PL_perldb && (PL_perldb & PERLDBf_SAVESRC_INVALID)) -#ifdef USE_LOCALE_NUMERIC - -/* Returns non-zero If the plain locale pragma without a parameter is in effect +#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 (CopHINTS_get(PL_curcop) & HINT_LOCALE) +# define IN_LOCALE_RUNTIME cBOOL(CopHINTS_get(PL_curcop) & HINT_LOCALE) -/* Returns non-zero If either form of the locale pragma is in effect */ -#define IN_SOME_LOCALE_FORM_RUNTIME \ - (CopHINTS_get(PL_curcop) & (HINT_LOCALE|HINT_LOCALE_NOT_CHARS)) +/* 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 (PL_hints & HINT_LOCALE) -#define IN_SOME_LOCALE_FORM_COMPILETIME \ - (PL_hints & (HINT_LOCALE|HINT_LOCALE_NOT_CHARS)) +# 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 \ +# define IN_LOCALE \ (IN_PERL_COMPILETIME ? IN_LOCALE_COMPILETIME : IN_LOCALE_RUNTIME) -#define IN_SOME_LOCALE_FORM \ +# 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 \ + cBOOL(CopHINTS_get(PL_curcop) & HINT_LOCALE_PARTIAL) + +# define IN_LC_COMPILETIME(category) \ + (IN_LC_ALL_COMPILETIME || (IN_LC_PARTIAL_COMPILETIME \ + && _is_in_locale_category(TRUE, (category)))) +# define IN_LC_RUNTIME(category) \ + (IN_LC_ALL_RUNTIME || (IN_LC_PARTIAL_RUNTIME \ + && _is_in_locale_category(FALSE, (category)))) +# define IN_LC(category) \ + (IN_LC_COMPILETIME(category) || IN_LC_RUNTIME(category)) + +#else /* No locale usage */ +# 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 + +#ifdef USE_LOCALE_NUMERIC + /* These macros are for toggling between the underlying locale (LOCAL) and the * C locale. */ @@ -5242,18 +5713,24 @@ typedef struct am_table_short AMTS; * RESTORE_LC_NUMERIC() in all cases restores the locale to what it was before * these were called */ +#define _NOT_IN_NUMERIC_STANDARD (! PL_numeric_standard) + +/* We can lock the category to stay in the C locale, making requests to the + * contrary noops, in the dynamic scope by setting PL_numeric_standard to 2 */ +#define _NOT_IN_NUMERIC_LOCAL (! PL_numeric_local && PL_numeric_standard < 2) + #define DECLARATION_FOR_STORE_LC_NUMERIC_SET_TO_NEEDED \ void (*_restore_LC_NUMERIC_function)(pTHX) = NULL; #define STORE_LC_NUMERIC_SET_TO_NEEDED() \ - if (IN_SOME_LOCALE_FORM) { \ - if (! PL_numeric_local) { \ - SET_NUMERIC_LOCAL(); \ + if (IN_LC(LC_NUMERIC)) { \ + if (_NOT_IN_NUMERIC_LOCAL) { \ + set_numeric_local(); \ _restore_LC_NUMERIC_function = &Perl_set_numeric_standard; \ } \ } \ else { \ - if (! PL_numeric_standard) { \ + if (_NOT_IN_NUMERIC_STANDARD) { \ SET_NUMERIC_STANDARD(); \ _restore_LC_NUMERIC_function = &Perl_set_numeric_local; \ } \ @@ -5270,35 +5747,47 @@ typedef struct am_table_short AMTS; /* 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() \ - set_numeric_standard(); +#define SET_NUMERIC_STANDARD() \ + STMT_START { if (_NOT_IN_NUMERIC_STANDARD) set_numeric_standard(); \ + } STMT_END -#define SET_NUMERIC_LOCAL() \ - set_numeric_local(); +#define SET_NUMERIC_LOCAL() \ + STMT_START { if (_NOT_IN_NUMERIC_LOCAL) \ + set_numeric_local(); } 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_NUMERIC_LOCAL_SET_STANDARD() \ - bool was_local = PL_numeric_local; \ - if (was_local) SET_NUMERIC_STANDARD(); +#define STORE_NUMERIC_LOCAL_SET_STANDARD() \ + bool _was_local = _NOT_IN_NUMERIC_STANDARD; \ + if (_was_local) set_numeric_standard(); /* Doesn't change to underlying locale unless within the scope of some form of * 'use locale'. This is the usual desired behavior. */ -#define STORE_NUMERIC_STANDARD_SET_LOCAL() \ - bool was_standard = PL_numeric_standard && IN_SOME_LOCALE_FORM; \ - if (was_standard) SET_NUMERIC_LOCAL(); +#define STORE_NUMERIC_STANDARD_SET_LOCAL() \ + bool _was_standard = _NOT_IN_NUMERIC_LOCAL \ + && IN_LC(LC_NUMERIC); \ + if (_was_standard) set_numeric_local(); /* Rarely, we want to change to the underlying locale even outside of 'use * locale'. This is principally in the POSIX:: functions */ -#define STORE_NUMERIC_STANDARD_FORCE_LOCAL() \ - bool was_standard = PL_numeric_standard; \ - if (was_standard) SET_NUMERIC_LOCAL(); +#define STORE_NUMERIC_STANDARD_FORCE_LOCAL() \ + bool _was_standard = _NOT_IN_NUMERIC_LOCAL; \ + if (_was_standard) set_numeric_local(); + +/* Lock to the C locale until unlock is called */ +#define LOCK_NUMERIC_STANDARD() \ + (__ASSERT_(PL_numeric_standard) \ + PL_numeric_standard = 2) + +#define UNLOCK_NUMERIC_STANDARD() \ + (__ASSERT_(PL_numeric_standard == 2) \ + PL_numeric_standard = 1) #define RESTORE_NUMERIC_LOCAL() \ - if (was_local) SET_NUMERIC_LOCAL(); + if (_was_local) set_numeric_local(); #define RESTORE_NUMERIC_STANDARD() \ - if (was_standard) SET_NUMERIC_STANDARD(); + if (_was_standard) SET_NUMERIC_STANDARD(); #define Atof my_atof @@ -5316,13 +5805,25 @@ typedef struct am_table_short AMTS; #define STORE_LC_NUMERIC_SET_TO_NEEDED() #define DECLARE_STORE_LC_NUMERIC_SET_TO_NEEDED() #define RESTORE_LC_NUMERIC() +#define LOCK_NUMERIC_STANDARD() +#define UNLOCK_NUMERIC_STANDARD() #define Atof my_atof -#define IN_LOCALE_RUNTIME 0 -#define IN_LOCALE_COMPILETIME 0 #endif /* !USE_LOCALE_NUMERIC */ +#ifdef USE_QUADMATH +# define Perl_strtod(s, e) strtoflt128(s, e) +#elif defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE) +# if defined(HAS_STRTOLD) +# define Perl_strtod(s, e) strtold(s, e) +# elif defined(HAS_STRTOD) +# define Perl_strtod(s, e) (NV)strtod(s, e) /* Unavoidable loss. */ +# endif +#elif defined(HAS_STRTOD) +# define Perl_strtod(s, e) strtod(s, e) +#endif + #if !defined(Strtol) && defined(USE_64_BIT_INT) && defined(IV_IS_QUAD) && \ (QUADKIND == QUAD_IS_LONG_LONG || QUADKIND == QUAD_IS___INT64) # ifdef __hpux @@ -5383,24 +5884,6 @@ typedef struct am_table_short AMTS; # define Atoul(s) Strtoul(s, NULL, 10) #endif - -/* if these never got defined, they need defaults */ -#ifndef PERL_SET_CONTEXT -# define PERL_SET_CONTEXT(i) PERL_SET_INTERP(i) -#endif - -#ifndef PERL_GET_CONTEXT -# define PERL_GET_CONTEXT PERL_GET_INTERP -#endif - -#ifndef PERL_GET_THX -# define PERL_GET_THX ((void*)NULL) -#endif - -#ifndef PERL_SET_THX -# define PERL_SET_THX(t) NOOP -#endif - #ifndef PERL_SCRIPT_MODE #define PERL_SCRIPT_MODE "r" #endif @@ -5422,7 +5905,7 @@ typedef struct am_table_short AMTS; #ifndef PERL_MICRO # ifndef PERL_ASYNC_CHECK -# define PERL_ASYNC_CHECK() if (PL_sig_pending) PL_signalhook(aTHX) +# define PERL_ASYNC_CHECK() if (UNLIKELY(PL_sig_pending)) PL_signalhook(aTHX) # endif #endif @@ -5600,7 +6083,7 @@ int flock(int fd, int op); #endif #if O_TEXT != O_BINARY - /* If you have different O_TEXT and O_BINARY and you are a CLRF shop, + /* If you have different O_TEXT and O_BINARY and you are a CRLF shop, * that is, you are somehow DOSish. */ # if defined(__HAIKU__) || defined(__VOS__) || defined(__CYGWIN__) /* Haiku has O_TEXT != O_BINARY but O_TEXT and O_BINARY have no effect; @@ -5632,6 +6115,7 @@ int flock(int fd, int op); #define IS_NUMBER_NEG 0x08 /* leading minus sign */ #define IS_NUMBER_INFINITY 0x10 /* this is big */ #define IS_NUMBER_NAN 0x20 /* this is not */ +#define IS_NUMBER_TRAILING 0x40 /* number has trailing trash */ #define GROK_NUMERIC_RADIX(sp, send) grok_numeric_radix(sp, send) @@ -5641,6 +6125,9 @@ int flock(int fd, int op); #define PERL_SCAN_SILENT_ILLDIGIT 0x04 /* grok_??? not warn about illegal digits */ #define PERL_SCAN_SILENT_NON_PORTABLE 0x08 /* grok_??? not warn about very large numbers which are <= UV_MAX */ +#define PERL_SCAN_TRAILING 0x10 /* grok_number_flags() allow trailing + and set IS_NUMBER_TRAILING */ + /* Output flags: */ #define PERL_SCAN_GREATER_THAN_UV_MAX 0x02 /* should this merge with above? */