3 * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,
4 * 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * "That only makes eleven (plus one mislaid) and not fourteen,
13 * unless wizards count differently to other people." --Beorn
15 * [p.115 of _The Hobbit_: "Queer Lodgings"]
19 =head1 Numeric functions
23 This file contains all the stuff needed by perl for manipulating numeric
24 values, including such things as replacements for the OS's atof() function
29 #define PERL_IN_NUMERIC_C
35 S_strtod(pTHX_ const char * const s, char ** e)
37 DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
40 STORE_LC_NUMERIC_SET_TO_NEEDED();
44 result = strtoflt128(s, e);
46 # elif defined(HAS_STRTOLD) && defined(HAS_LONG_DOUBLE) \
47 && defined(USE_LONG_DOUBLE)
48 # if defined(__MINGW64_VERSION_MAJOR)
49 /***********************************************
50 We are unable to use strtold because of
51 https://sourceforge.net/p/mingw-w64/bugs/711/
53 https://sourceforge.net/p/mingw-w64/bugs/725/
55 but __mingw_strtold is fine.
56 ***********************************************/
58 result = __mingw_strtold(s, e);
62 result = strtold(s, e);
65 # elif defined(HAS_STRTOD)
67 result = strtod(s, e);
70 # error No strtod() equivalent found
78 #endif /* #ifdef Perl_strtod */
84 This function is equivalent to the libc strtod() function, and is available
85 even on platforms that lack plain strtod(). Its return value is the best
86 available precision depending on platform capabilities and F<Configure>
89 It properly handles the locale radix character, meaning it expects a dot except
90 when called from within the scope of S<C<use locale>>, in which case the radix
91 character should be that specified by the current locale.
93 The synonym Strtod() may be used instead.
100 Perl_my_strtod(const char * const s, char **e)
104 PERL_ARGS_ASSERT_MY_STRTOD;
108 return S_strtod(aTHX_ s, e);
114 char ** end_ptr = NULL;
116 *end_ptr = my_atof2(s, &result);
134 Perl_cast_ulong(NV f)
137 return f < I32_MIN ? (U32) I32_MIN : (U32)(I32) f;
138 if (f < U32_MAX_P1) {
140 if (f < U32_MAX_P1_HALF)
142 f -= U32_MAX_P1_HALF;
143 return ((U32) f) | (1 + (U32_MAX >> 1));
148 return f > 0 ? U32_MAX : 0 /* NaN */;
155 return f < I32_MIN ? I32_MIN : (I32) f;
156 if (f < U32_MAX_P1) {
158 if (f < U32_MAX_P1_HALF)
160 f -= U32_MAX_P1_HALF;
161 return (I32)(((U32) f) | (1 + (U32_MAX >> 1)));
166 return f > 0 ? (I32)U32_MAX : 0 /* NaN */;
173 return f < IV_MIN ? IV_MIN : (IV) f;
176 /* For future flexibility allowing for sizeof(UV) >= sizeof(IV) */
177 if (f < UV_MAX_P1_HALF)
180 return (IV)(((UV) f) | (1 + (UV_MAX >> 1)));
185 return f > 0 ? (IV)UV_MAX : 0 /* NaN */;
192 return f < IV_MIN ? (UV) IV_MIN : (UV)(IV) f;
195 if (f < UV_MAX_P1_HALF)
198 return ((UV) f) | (1 + (UV_MAX >> 1));
203 return f > 0 ? UV_MAX : 0 /* NaN */;
209 converts a string representing a binary number to numeric form.
211 On entry C<start> and C<*len_p> give the string to scan, C<*flags> gives
212 conversion flags, and C<result> should be C<NULL> or a pointer to an NV. The
213 scan stops at the end of the string, or at just before the first invalid
214 character. Unless C<PERL_SCAN_SILENT_ILLDIGIT> is set in C<*flags>,
215 encountering an invalid character (except NUL) will also trigger a warning. On
216 return C<*len_p> is set to the length of the scanned string, and C<*flags>
219 If the value is <= C<UV_MAX> it is returned as a UV, the output flags are clear,
220 and nothing is written to C<*result>. If the value is > C<UV_MAX>, C<grok_bin>
221 returns C<UV_MAX>, sets C<PERL_SCAN_GREATER_THAN_UV_MAX> in the output flags,
222 and writes an approximation of the correct value into C<*result> (which is an
223 NV; or the approximation is discarded if C<result> is NULL).
225 The binary number may optionally be prefixed with C<"0b"> or C<"b"> unless
226 C<PERL_SCAN_DISALLOW_PREFIX> is set in C<*flags> on entry.
228 If C<PERL_SCAN_ALLOW_UNDERSCORES> is set in C<*flags> then any or all pairs of
229 digits may be separated from each other by a single underscore; also a single
230 leading underscore is accepted.
232 =for apidoc Amnh||PERL_SCAN_ALLOW_UNDERSCORES
233 =for apidoc Amnh||PERL_SCAN_DISALLOW_PREFIX
234 =for apidoc Amnh||PERL_SCAN_GREATER_THAN_UV_MAX
235 =for apidoc Amnh||PERL_SCAN_SILENT_ILLDIGIT
239 Not documented yet because experimental is C<PERL_SCAN_SILENT_NON_PORTABLE
240 which suppresses any message for non-portable numbers that are still valid
245 Perl_grok_bin(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result)
247 PERL_ARGS_ASSERT_GROK_BIN;
249 return grok_bin(start, len_p, flags, result);
255 converts a string representing a hex number to numeric form.
257 On entry C<start> and C<*len_p> give the string to scan, C<*flags> gives
258 conversion flags, and C<result> should be C<NULL> or a pointer to an NV. The
259 scan stops at the end of the string, or at just before the first invalid
260 character. Unless C<PERL_SCAN_SILENT_ILLDIGIT> is set in C<*flags>,
261 encountering an invalid character (except NUL) will also trigger a warning. On
262 return C<*len_p> is set to the length of the scanned string, and C<*flags>
265 If the value is <= C<UV_MAX> it is returned as a UV, the output flags are clear,
266 and nothing is written to C<*result>. If the value is > C<UV_MAX>, C<grok_hex>
267 returns C<UV_MAX>, sets C<PERL_SCAN_GREATER_THAN_UV_MAX> in the output flags,
268 and writes an approximation of the correct value into C<*result> (which is an
269 NV; or the approximation is discarded if C<result> is NULL).
271 The hex number may optionally be prefixed with C<"0x"> or C<"x"> unless
272 C<PERL_SCAN_DISALLOW_PREFIX> is set in C<*flags> on entry.
274 If C<PERL_SCAN_ALLOW_UNDERSCORES> is set in C<*flags> then any or all pairs of
275 digits may be separated from each other by a single underscore; also a single
276 leading underscore is accepted.
280 Not documented yet because experimental is C<PERL_SCAN_SILENT_NON_PORTABLE>
281 which suppresses any message for non-portable numbers, but which are valid
286 Perl_grok_hex(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result)
288 PERL_ARGS_ASSERT_GROK_HEX;
290 return grok_hex(start, len_p, flags, result);
296 converts a string representing an octal number to numeric form.
298 On entry C<start> and C<*len_p> give the string to scan, C<*flags> gives
299 conversion flags, and C<result> should be C<NULL> or a pointer to an NV. The
300 scan stops at the end of the string, or at just before the first invalid
301 character. Unless C<PERL_SCAN_SILENT_ILLDIGIT> is set in C<*flags>,
302 encountering an invalid character (except NUL) will also trigger a warning. On
303 return C<*len_p> is set to the length of the scanned string, and C<*flags>
306 If the value is <= C<UV_MAX> it is returned as a UV, the output flags are clear,
307 and nothing is written to C<*result>. If the value is > C<UV_MAX>, C<grok_oct>
308 returns C<UV_MAX>, sets C<PERL_SCAN_GREATER_THAN_UV_MAX> in the output flags,
309 and writes an approximation of the correct value into C<*result> (which is an
310 NV; or the approximation is discarded if C<result> is NULL).
312 If C<PERL_SCAN_ALLOW_UNDERSCORES> is set in C<*flags> then any or all pairs of
313 digits may be separated from each other by a single underscore; also a single
314 leading underscore is accepted.
316 The the C<PERL_SCAN_DISALLOW_PREFIX> flag is always treated as being set for
321 Not documented yet because experimental is C<PERL_SCAN_SILENT_NON_PORTABLE>
322 which suppresses any message for non-portable numbers, but which are valid
327 Perl_grok_oct(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result)
329 PERL_ARGS_ASSERT_GROK_OCT;
331 return grok_oct(start, len_p, flags, result);
335 S_output_non_portable(pTHX_ const U8 base)
337 /* Display the proper message for a number in the given input base not
338 * fitting in 32 bits */
339 const char * which = (base == 2)
340 ? "Binary number > 0b11111111111111111111111111111111"
342 ? "Octal number > 037777777777"
343 : "Hexadecimal number > 0xffffffff";
345 PERL_ARGS_ASSERT_OUTPUT_NON_PORTABLE;
347 /* Also there are listings for the other two. That's because, since they
348 * are the first word, it would be hard for a user to find them there
349 * starting with a %s */
350 /* diag_listed_as: Hexadecimal number > 0xffffffff non-portable */
351 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE), "%s non-portable", which);
355 Perl_grok_bin_oct_hex(pTHX_ const char *start,
359 const unsigned shift, /* 1 for binary; 3 for octal;
366 const char *s0 = start;
369 STRLEN bytes_so_far; /* How many real digits have been processed */
372 const PERL_UINT_FAST8_T base = 1 << shift; /* 2, 8, or 16 */
373 const UV max_div= UV_MAX / base; /* Value above which, the next digit
374 processed would overflow */
375 const I32 input_flags = *flags;
376 const bool allow_underscores =
377 cBOOL(input_flags & PERL_SCAN_ALLOW_UNDERSCORES);
378 bool overflowed = FALSE;
380 /* In overflows, this keeps track of how much to multiply the overflowed NV
381 * by as we continue to parse the remaining digits */
384 /* This function unifies the core of grok_bin, grok_oct, and grok_hex. It
385 * is optimized for hex conversion. For example, it uses XDIGIT_VALUE to
386 * find the numeric value of a digit. That requires more instructions than
387 * OCTAL_VALUE would, but gives the same result for the narrowed range of
388 * octal digits; same for binary. If it were ever critical to squeeze more
389 * performance from this, the function could become grok_hex, and a regen
390 * perl script could scan it and write out two edited copies for the other
391 * two functions. That would improve the performance of all three
392 * somewhat. Besides eliminating XDIGIT_VALUE for the other two, extra
393 * parameters are now passed to this to avoid conditionals. Those could
394 * become declared consts, like:
395 * const U8 base = 16;
400 PERL_ARGS_ASSERT_GROK_BIN_OCT_HEX;
402 ASSUME(inRANGE(shift, 1, 4) && shift != 2);
404 /* Clear output flags; unlikely to find a problem that sets them */
407 if (!(input_flags & PERL_SCAN_DISALLOW_PREFIX)) {
409 /* strip off leading b or 0b; x or 0x.
410 for compatibility silently suffer "b" and "0b" as valid binary; "x"
411 and "0x" as valid hex numbers. */
413 if (isALPHA_FOLD_EQ(s0[0], prefix)) {
417 else if (len >= 2 && s0[0] == '0' && (isALPHA_FOLD_EQ(s0[1], prefix))) {
424 s = s0; /* s0 potentially advanced from 'start' */
426 /* Unroll the loop so that the first 7 digits are branchless except for the
427 * switch. An eighth one could overflow a 32 bit word. This should
428 * completely handle the common case without needing extra checks */
433 if (! _generic_isCC(*s, class_bit)) break;
434 value = (value << shift) | XDIGIT_VALUE(*s);
438 if (! _generic_isCC(*s, class_bit)) break;
439 value = (value << shift) | XDIGIT_VALUE(*s);
443 if (! _generic_isCC(*s, class_bit)) break;
444 value = (value << shift) | XDIGIT_VALUE(*s);
448 if (! _generic_isCC(*s, class_bit)) break;
449 value = (value << shift) | XDIGIT_VALUE(*s);
453 if (! _generic_isCC(*s, class_bit)) break;
454 value = (value << shift) | XDIGIT_VALUE(*s);
458 if (! _generic_isCC(*s, class_bit)) break;
459 value = (value << shift) | XDIGIT_VALUE(*s);
463 if (! _generic_isCC(*s, class_bit)) break;
464 value = (value << shift) | XDIGIT_VALUE(*s);
466 if (LIKELY(len <= 7)) {
474 bytes_so_far = s - s0;
475 factor = shift << bytes_so_far;
479 if (_generic_isCC(*s, class_bit)) {
480 /* Write it in this wonky order with a goto to attempt to get the
481 compiler to make the common case integer-only loop pretty tight.
482 With gcc seems to be much straighter code than old scan_hex.
483 (khw suspects that adding a LIKELY() just above would do the
486 if (LIKELY(value <= max_div)) {
487 value = (value << shift) | XDIGIT_VALUE(*s);
488 /* Note XDIGIT_VALUE() is branchless, works on binary
489 * and octal as well, so can be used here, without
490 * slowing those down */
495 /* Bah. We are about to overflow. Instead, add the unoverflowed
496 * value to an NV that contains an approximation to the correct
497 * value. Each time through the loop we have increased 'factor' so
498 * that it gives how much the current approximation needs to
499 * effectively be shifted to make room for this new value */
500 value_nv *= (NV) factor;
501 value_nv += (NV) value;
503 /* Then we keep accumulating digits, until all are parsed. We
504 * start over using the current input value. This will be added to
505 * 'value_nv' eventually, either when all digits are gone, or we
506 * have overflowed this fresh start. */
507 value = XDIGIT_VALUE(*s);
512 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
513 "Integer overflow in %s number",
514 (base == 16) ? "hexadecimal"
525 && _generic_isCC(s[1], class_bit))
533 && ! (input_flags & PERL_SCAN_SILENT_ILLDIGIT)
534 && ckWARN(WARN_DIGIT))
537 Perl_warner(aTHX_ packWARN(WARN_DIGIT),
538 "Illegal %s digit '%c' ignored",
544 else if (isDIGIT(*s)) { /* octal base */
546 /* Allow \octal to work the DWIM way (that is, stop scanning as
547 * soon as non-octal characters are seen, complain only if
548 * someone seems to want to use the digits eight and nine.
549 * Since we know it is not octal, then if isDIGIT, must be an 8
551 Perl_warner(aTHX_ packWARN(WARN_DIGIT),
552 "Illegal octal digit '%c' ignored", *s);
561 if (LIKELY(! overflowed)) {
563 if ( UNLIKELY(value > 0xffffffff)
564 && ! (input_flags & PERL_SCAN_SILENT_NON_PORTABLE))
566 output_non_portable(base);
572 /* Overflowed: Calculate the final overflow approximation */
573 value_nv *= (NV) factor;
574 value_nv += (NV) value;
576 output_non_portable(base);
578 *flags = PERL_SCAN_GREATER_THAN_UV_MAX;
587 For backwards compatibility. Use C<grok_bin> instead.
591 For backwards compatibility. Use C<grok_hex> instead.
595 For backwards compatibility. Use C<grok_oct> instead.
601 Perl_scan_bin(pTHX_ const char *start, STRLEN len, STRLEN *retlen)
604 I32 flags = *retlen ? PERL_SCAN_ALLOW_UNDERSCORES : 0;
605 const UV ruv = grok_bin (start, &len, &flags, &rnv);
607 PERL_ARGS_ASSERT_SCAN_BIN;
610 return (flags & PERL_SCAN_GREATER_THAN_UV_MAX) ? rnv : (NV)ruv;
614 Perl_scan_oct(pTHX_ const char *start, STRLEN len, STRLEN *retlen)
617 I32 flags = *retlen ? PERL_SCAN_ALLOW_UNDERSCORES : 0;
618 const UV ruv = grok_oct (start, &len, &flags, &rnv);
620 PERL_ARGS_ASSERT_SCAN_OCT;
623 return (flags & PERL_SCAN_GREATER_THAN_UV_MAX) ? rnv : (NV)ruv;
627 Perl_scan_hex(pTHX_ const char *start, STRLEN len, STRLEN *retlen)
630 I32 flags = *retlen ? PERL_SCAN_ALLOW_UNDERSCORES : 0;
631 const UV ruv = grok_hex (start, &len, &flags, &rnv);
633 PERL_ARGS_ASSERT_SCAN_HEX;
636 return (flags & PERL_SCAN_GREATER_THAN_UV_MAX) ? rnv : (NV)ruv;
640 =for apidoc grok_numeric_radix
642 Scan and skip for a numeric decimal separator (radix).
647 Perl_grok_numeric_radix(pTHX_ const char **sp, const char *send)
649 PERL_ARGS_ASSERT_GROK_NUMERIC_RADIX;
651 #ifdef USE_LOCALE_NUMERIC
653 if (IN_LC(LC_NUMERIC)) {
656 bool matches_radix = FALSE;
657 DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
659 STORE_LC_NUMERIC_FORCE_TO_UNDERLYING();
661 radix = SvPV(PL_numeric_radix_sv, len);
662 radix = savepvn(radix, len);
664 RESTORE_LC_NUMERIC();
666 if (*sp + len <= send) {
667 matches_radix = memEQ(*sp, radix, len);
680 /* always try "." if numeric radix didn't match because
681 * we may have data from different locales mixed */
682 if (*sp < send && **sp == '.') {
691 =for apidoc grok_infnan
693 Helper for C<grok_number()>, accepts various ways of spelling "infinity"
694 or "not a number", and returns one of the following flag combinations:
698 IS_NUMBER_INFINITY | IS_NUMBER_NEG
699 IS_NUMBER_NAN | IS_NUMBER_NEG
702 possibly |-ed with C<IS_NUMBER_TRAILING>.
704 If an infinity or a not-a-number is recognized, C<*sp> will point to
705 one byte past the end of the recognized string. If the recognition fails,
706 zero is returned, and C<*sp> will not move.
708 =for apidoc Amn|bool|IS_NUMBER_GREATER_THAN_UV_MAX
709 =for apidoc Amn|bool|IS_NUMBER_INFINITY
710 =for apidoc Amn|bool|IS_NUMBER_IN_UV
711 =for apidoc Amn|bool|IS_NUMBER_NAN
712 =for apidoc Amn|bool|IS_NUMBER_NEG
713 =for apidoc Amn|bool|IS_NUMBER_NOT_INT
719 Perl_grok_infnan(pTHX_ const char** sp, const char* send)
723 #if defined(NV_INF) || defined(NV_NAN)
724 bool odh = FALSE; /* one-dot-hash: 1.#INF */
726 PERL_ARGS_ASSERT_GROK_INFNAN;
729 s++; if (s == send) return 0;
731 else if (*s == '-') {
732 flags |= IS_NUMBER_NEG; /* Yes, -NaN happens. Incorrect but happens. */
733 s++; if (s == send) return 0;
737 /* Visual C: 1.#SNAN, -1.#QNAN, 1#INF, 1.#IND (maybe also 1.#NAN)
738 * Let's keep the dot optional. */
739 s++; if (s == send) return 0;
741 s++; if (s == send) return 0;
744 s++; if (s == send) return 0;
750 if (isALPHA_FOLD_EQ(*s, 'I')) {
751 /* INF or IND (1.#IND is "indeterminate", a certain type of NAN) */
753 s++; if (s == send || isALPHA_FOLD_NE(*s, 'N')) return 0;
754 s++; if (s == send) return 0;
755 if (isALPHA_FOLD_EQ(*s, 'F')) {
757 if (s < send && (isALPHA_FOLD_EQ(*s, 'I'))) {
759 flags | IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT | IS_NUMBER_TRAILING;
760 s++; if (s == send || isALPHA_FOLD_NE(*s, 'N')) return fail;
761 s++; if (s == send || isALPHA_FOLD_NE(*s, 'I')) return fail;
762 s++; if (s == send || isALPHA_FOLD_NE(*s, 'T')) return fail;
763 s++; if (s == send || isALPHA_FOLD_NE(*s, 'Y')) return fail;
766 while (*s == '0') { /* 1.#INF00 */
770 while (s < send && isSPACE(*s))
772 if (s < send && *s) {
773 flags |= IS_NUMBER_TRAILING;
775 flags |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT;
777 else if (isALPHA_FOLD_EQ(*s, 'D') && odh) { /* 1.#IND */
779 flags |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT;
780 while (*s == '0') { /* 1.#IND00 */
784 flags |= IS_NUMBER_TRAILING;
790 /* Maybe NAN of some sort */
792 if (isALPHA_FOLD_EQ(*s, 'S') || isALPHA_FOLD_EQ(*s, 'Q')) {
794 /* XXX do something with the snan/qnan difference */
795 s++; if (s == send) return 0;
798 if (isALPHA_FOLD_EQ(*s, 'N')) {
799 s++; if (s == send || isALPHA_FOLD_NE(*s, 'A')) return 0;
800 s++; if (s == send || isALPHA_FOLD_NE(*s, 'N')) return 0;
803 flags |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT;
808 /* NaN can be followed by various stuff (NaNQ, NaNS), but
809 * there are also multiple different NaN values, and some
810 * implementations output the "payload" values,
811 * e.g. NaN123, NAN(abc), while some legacy implementations
812 * have weird stuff like NaN%. */
813 if (isALPHA_FOLD_EQ(*s, 'q') ||
814 isALPHA_FOLD_EQ(*s, 's')) {
815 /* "nanq" or "nans" are ok, though generating
816 * these portably is tricky. */
823 /* C99 style "nan(123)" or Perlish equivalent "nan($uv)". */
827 return flags | IS_NUMBER_TRAILING;
830 while (t < send && *t && *t != ')') {
834 return flags | IS_NUMBER_TRAILING;
839 if (s[0] == '0' && s + 2 < t &&
840 isALPHA_FOLD_EQ(s[1], 'x') &&
843 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
844 nanval = grok_hex(s, &len, &flags, NULL);
845 if ((flags & PERL_SCAN_GREATER_THAN_UV_MAX)) {
848 nantype = IS_NUMBER_IN_UV;
851 } else if (s[0] == '0' && s + 2 < t &&
852 isALPHA_FOLD_EQ(s[1], 'b') &&
853 (s[2] == '0' || s[2] == '1')) {
855 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
856 nanval = grok_bin(s, &len, &flags, NULL);
857 if ((flags & PERL_SCAN_GREATER_THAN_UV_MAX)) {
860 nantype = IS_NUMBER_IN_UV;
866 grok_number_flags(s, t - s, &nanval,
868 PERL_SCAN_ALLOW_UNDERSCORES);
869 /* Unfortunately grok_number_flags() doesn't
870 * tell how far we got and the ')' will always
871 * be "trailing", so we need to double-check
872 * whether we had something dubious. */
873 for (u = s; u < t; u++) {
875 flags |= IS_NUMBER_TRAILING;
882 /* XXX Doesn't do octal: nan("0123").
883 * Probably not a big loss. */
885 if ((nantype & IS_NUMBER_NOT_INT) ||
886 !(nantype && IS_NUMBER_IN_UV)) {
887 /* XXX the nanval is currently unused, that is,
888 * not inserted as the NaN payload of the NV.
889 * But the above code already parses the C99
890 * nan(...) format. See below, and see also
891 * the nan() in POSIX.xs.
893 * Certain configuration combinations where
894 * NVSIZE is greater than UVSIZE mean that
895 * a single UV cannot contain all the possible
896 * NaN payload bits. There would need to be
897 * some more generic syntax than "nan($uv)".
899 * Issues to keep in mind:
901 * (1) In most common cases there would
902 * not be an integral number of bytes that
903 * could be set, only a certain number of bits.
904 * For example for the common case of
905 * NVSIZE == UVSIZE == 8 there is room for 52
906 * bits in the payload, but the most significant
907 * bit is commonly reserved for the
908 * signaling/quiet bit, leaving 51 bits.
909 * Furthermore, the C99 nan() is supposed
910 * to generate quiet NaNs, so it is doubtful
911 * whether it should be able to generate
912 * signaling NaNs. For the x86 80-bit doubles
913 * (if building a long double Perl) there would
914 * be 62 bits (s/q bit being the 63rd).
916 * (2) Endianness of the payload bits. If the
917 * payload is specified as an UV, the low-order
918 * bits of the UV are naturally little-endianed
919 * (rightmost) bits of the payload. The endianness
920 * of UVs and NVs can be different. */
924 flags |= IS_NUMBER_TRAILING;
927 /* Looked like nan(...), but no close paren. */
928 flags |= IS_NUMBER_TRAILING;
931 while (s < send && isSPACE(*s))
933 if (s < send && *s) {
934 /* Note that we here implicitly accept (parse as
935 * "nan", but with warnings) also any other weird
936 * trailing stuff for "nan". In the above we just
937 * check that if we got the C99-style "nan(...)",
938 * the "..." looks sane.
939 * If in future we accept more ways of specifying
940 * the nan payload, the accepting would happen around
942 flags |= IS_NUMBER_TRAILING;
951 while (s < send && isSPACE(*s))
955 PERL_UNUSED_ARG(send);
956 #endif /* #if defined(NV_INF) || defined(NV_NAN) */
962 =for apidoc grok_number_flags
964 Recognise (or not) a number. The type of the number is returned
965 (0 if unrecognised), otherwise it is a bit-ORed combination of
966 C<IS_NUMBER_IN_UV>, C<IS_NUMBER_GREATER_THAN_UV_MAX>, C<IS_NUMBER_NOT_INT>,
967 C<IS_NUMBER_NEG>, C<IS_NUMBER_INFINITY>, C<IS_NUMBER_NAN> (defined in perl.h).
969 If the value of the number can fit in a UV, it is returned in C<*valuep>.
970 C<IS_NUMBER_IN_UV> will be set to indicate that C<*valuep> is valid, C<IS_NUMBER_IN_UV>
971 will never be set unless C<*valuep> is valid, but C<*valuep> may have been assigned
972 to during processing even though C<IS_NUMBER_IN_UV> is not set on return.
973 If C<valuep> is C<NULL>, C<IS_NUMBER_IN_UV> will be set for the same cases as when
974 C<valuep> is non-C<NULL>, but no actual assignment (or SEGV) will occur.
976 C<IS_NUMBER_NOT_INT> will be set with C<IS_NUMBER_IN_UV> if trailing decimals were
977 seen (in which case C<*valuep> gives the true value truncated to an integer), and
978 C<IS_NUMBER_NEG> if the number is negative (in which case C<*valuep> holds the
979 absolute value). C<IS_NUMBER_IN_UV> is not set if e notation was used or the
980 number is larger than a UV.
982 C<flags> allows only C<PERL_SCAN_TRAILING>, which allows for trailing
983 non-numeric text on an otherwise successful I<grok>, setting
984 C<IS_NUMBER_TRAILING> on the result.
986 =for apidoc Amnh||PERL_SCAN_TRAILING
988 =for apidoc grok_number
990 Identical to C<grok_number_flags()> with C<flags> set to zero.
995 Perl_grok_number(pTHX_ const char *pv, STRLEN len, UV *valuep)
997 PERL_ARGS_ASSERT_GROK_NUMBER;
999 return grok_number_flags(pv, len, valuep, 0);
1002 static const UV uv_max_div_10 = UV_MAX / 10;
1003 static const U8 uv_max_mod_10 = UV_MAX % 10;
1006 Perl_grok_number_flags(pTHX_ const char *pv, STRLEN len, UV *valuep, U32 flags)
1009 const char * const send = pv + len;
1013 PERL_ARGS_ASSERT_GROK_NUMBER_FLAGS;
1015 if (UNLIKELY(isSPACE(*s))) {
1018 if (LIKELY(! isSPACE(*s))) goto non_space;
1025 /* See if signed. This assumes it is more likely to be unsigned, so
1026 * penalizes signed by an extra conditional; rewarding unsigned by one fewer
1027 * (because we detect '+' and '-' with a single test and then add a
1028 * conditional to determine which) */
1029 if (UNLIKELY((*s & ~('+' ^ '-')) == ('+' & '-') )) {
1031 /* Here, on ASCII platforms, *s is one of: 0x29 = ')', 2B = '+', 2D = '-',
1032 * 2F = '/'. That is, it is either a sign, or a character that doesn't
1033 * belong in a number at all (unless it's a radix character in a weird
1034 * locale). Given this, it's far more likely to be a minus than the
1035 * others. (On EBCDIC it is one of 42, 44, 46, 48, 4A, 4C, 4E, (not 40
1036 * because can't be a space) 60, 62, 64, 66, 68, 6A, 6C, 6E. Again, only
1037 * potentially a weird radix character, or 4E='+', or 60='-') */
1038 if (LIKELY(*s == '-')) {
1040 numtype = IS_NUMBER_NEG;
1042 else if (LIKELY(*s == '+'))
1044 else /* Can't just return failure here, as it could be a weird radix
1048 if (UNLIKELY(s == send))
1053 /* The first digit (after optional sign): note that might
1054 * also point to "infinity" or "nan", or "1.#INF". */
1057 /* next must be digit or the radix separator or beginning of infinity/nan */
1058 if (LIKELY(isDIGIT(*s))) {
1059 /* UVs are at least 32 bits, so the first 9 decimal digits cannot
1061 UV value = *s - '0'; /* Process this first (perhaps only) digit */
1067 default: /* 8 or more remaining characters */
1069 if (UNLIKELY(! inRANGE(digit, 0, 9))) break;
1070 value = value * 10 + digit;
1075 if (UNLIKELY(! inRANGE(digit, 0, 9))) break;
1076 value = value * 10 + digit;
1081 if (UNLIKELY(! inRANGE(digit, 0, 9))) break;
1082 value = value * 10 + digit;
1087 if (UNLIKELY(! inRANGE(digit, 0, 9))) break;
1088 value = value * 10 + digit;
1093 if (UNLIKELY(! inRANGE(digit, 0, 9))) break;
1094 value = value * 10 + digit;
1099 if (UNLIKELY(! inRANGE(digit, 0, 9))) break;
1100 value = value * 10 + digit;
1105 if (UNLIKELY(! inRANGE(digit, 0, 9))) break;
1106 value = value * 10 + digit;
1111 if (UNLIKELY(! inRANGE(digit, 0, 9))) break;
1112 value = value * 10 + digit;
1115 case 0: /* This case means the string consists of just the one
1116 digit we already have processed */
1118 /* If we got here by falling through other than the default: case, we
1119 * have processed the whole string, and know it consists entirely of
1120 * digits, and can't have overflowed. */
1124 return numtype|IS_NUMBER_IN_UV;
1127 /* Here, there are extra characters beyond the first 9 digits. Use a
1128 * loop to accumulate any remaining digits, until we get a non-digit or
1129 * would overflow. Note that leading zeros could cause us to get here
1130 * without being close to overflowing.
1132 * (The conditional 's >= send' above could be eliminated by making the
1133 * default: in the switch to instead be 'case 8:', and process longer
1134 * strings separately by using the loop below. This would penalize
1135 * these inputs by the extra instructions needed for looping. That
1136 * could be eliminated by copying the unwound code from above to handle
1137 * the firt 9 digits of these. khw didn't think this saving of a
1138 * single conditional was worth it.) */
1141 if (! inRANGE(digit, 0, 9)) goto mantissa_done;
1142 if ( value < uv_max_div_10
1143 || ( value == uv_max_div_10
1144 && digit <= uv_max_mod_10))
1146 value = value * 10 + digit;
1149 else { /* value would overflow. skip the remaining digits, don't
1150 worry about setting *valuep. */
1153 } while (s < send && isDIGIT(*s));
1155 IS_NUMBER_GREATER_THAN_UV_MAX;
1159 } /* End switch on input length */
1162 numtype |= IS_NUMBER_IN_UV;
1167 if (GROK_NUMERIC_RADIX(&s, send)) {
1168 numtype |= IS_NUMBER_NOT_INT;
1169 while (s < send && isDIGIT(*s)) /* optional digits after the radix */
1172 } /* End of *s is a digit */
1173 else if (GROK_NUMERIC_RADIX(&s, send)) {
1174 numtype |= IS_NUMBER_NOT_INT | IS_NUMBER_IN_UV; /* valuep assigned below */
1175 /* no digits before the radix means we need digits after it */
1176 if (s < send && isDIGIT(*s)) {
1179 } while (s < send && isDIGIT(*s));
1181 /* integer approximation is valid - it's 0. */
1189 if (LIKELY(s > d) && s < send) {
1190 /* we can have an optional exponent part */
1191 if (UNLIKELY(isALPHA_FOLD_EQ(*s, 'e'))) {
1193 if (s < send && (*s == '-' || *s == '+'))
1195 if (s < send && isDIGIT(*s)) {
1198 } while (s < send && isDIGIT(*s));
1200 else if (flags & PERL_SCAN_TRAILING)
1201 return numtype | IS_NUMBER_TRAILING;
1205 /* The only flag we keep is sign. Blow away any "it's UV" */
1206 numtype &= IS_NUMBER_NEG;
1207 numtype |= IS_NUMBER_NOT_INT;
1212 if (LIKELY(! isSPACE(*s))) goto end_space;
1219 if (UNLIKELY(memEQs(pv, len, "0 but true"))) {
1222 return IS_NUMBER_IN_UV;
1225 /* We could be e.g. at "Inf" or "NaN", or at the "#" of "1.#INF". */
1226 if ((s + 2 < send) && UNLIKELY(memCHRs("inqs#", toFOLD(*s)))) {
1227 /* Really detect inf/nan. Start at d, not s, since the above
1228 * code might have already consumed the "1." or "1". */
1229 const int infnan = Perl_grok_infnan(aTHX_ &d, send);
1230 if ((infnan & IS_NUMBER_INFINITY)) {
1231 return (numtype | infnan); /* Keep sign for infinity. */
1233 else if ((infnan & IS_NUMBER_NAN)) {
1234 return (numtype | infnan) & ~IS_NUMBER_NEG; /* Clear sign for nan. */
1237 else if (flags & PERL_SCAN_TRAILING) {
1238 return numtype | IS_NUMBER_TRAILING;
1245 =for apidoc grok_atoUV
1247 parse a string, looking for a decimal unsigned integer.
1249 On entry, C<pv> points to the beginning of the string;
1250 C<valptr> points to a UV that will receive the converted value, if found;
1251 C<endptr> is either NULL or points to a variable that points to one byte
1252 beyond the point in C<pv> that this routine should examine.
1253 If C<endptr> is NULL, C<pv> is assumed to be NUL-terminated.
1255 Returns FALSE if C<pv> doesn't represent a valid unsigned integer value (with
1256 no leading zeros). Otherwise it returns TRUE, and sets C<*valptr> to that
1259 If you constrain the portion of C<pv> that is looked at by this function (by
1260 passing a non-NULL C<endptr>), and if the intial bytes of that portion form a
1261 valid value, it will return TRUE, setting C<*endptr> to the byte following the
1262 final digit of the value. But if there is no constraint at what's looked at,
1263 all of C<pv> must be valid in order for TRUE to be returned.
1265 The only characters this accepts are the decimal digits '0'..'9'.
1267 As opposed to L<atoi(3)> or L<strtol(3)>, C<grok_atoUV> does NOT allow optional
1268 leading whitespace, nor negative inputs. If such features are required, the
1269 calling code needs to explicitly implement those.
1271 Note that this function returns FALSE for inputs that would overflow a UV,
1272 or have leading zeros. Thus a single C<0> is accepted, but not C<00> nor
1273 C<01>, C<002>, I<etc>.
1275 Background: C<atoi> has severe problems with illegal inputs, it cannot be
1276 used for incremental parsing, and therefore should be avoided
1277 C<atoi> and C<strtol> are also affected by locale settings, which can also be
1278 seen as a bug (global state controlled by user environment).
1285 Perl_grok_atoUV(const char *pv, UV *valptr, const char** endptr)
1289 const char* end2; /* Used in case endptr is NULL. */
1290 UV val = 0; /* The parsed value. */
1292 PERL_ARGS_ASSERT_GROK_ATOUV;
1298 end2 = s + strlen(s);
1308 /* Single-digit inputs are quite common. */
1310 if (s < *eptr && isDIGIT(*s)) {
1311 /* Fail on extra leading zeros. */
1314 while (s < *eptr && isDIGIT(*s)) {
1315 /* This could be unrolled like in grok_number(), but
1316 * the expected uses of this are not speed-needy, and
1317 * unlikely to need full 64-bitness. */
1318 const U8 digit = *s++ - '0';
1319 if (val < uv_max_div_10 ||
1320 (val == uv_max_div_10 && digit <= uv_max_mod_10)) {
1321 val = val * 10 + digit;
1328 if (endptr == NULL) {
1330 return FALSE; /* If endptr is NULL, no trailing non-digits allowed. */
1343 S_mulexp10(NV value, I32 exponent)
1355 /* On OpenVMS VAX we by default use the D_FLOAT double format,
1356 * and that format does not have *easy* capabilities [1] for
1357 * overflowing doubles 'silently' as IEEE fp does. We also need
1358 * to support G_FLOAT on both VAX and Alpha, and though the exponent
1359 * range is much larger than D_FLOAT it still doesn't do silent
1360 * overflow. Therefore we need to detect early whether we would
1361 * overflow (this is the behaviour of the native string-to-float
1362 * conversion routines, and therefore of native applications, too).
1364 * [1] Trying to establish a condition handler to trap floating point
1365 * exceptions is not a good idea. */
1367 /* In UNICOS and in certain Cray models (such as T90) there is no
1368 * IEEE fp, and no way at all from C to catch fp overflows gracefully.
1369 * There is something you can do if you are willing to use some
1370 * inline assembler: the instruction is called DFI-- but that will
1371 * disable *all* floating point interrupts, a little bit too large
1372 * a hammer. Therefore we need to catch potential overflows before
1375 #if ((defined(VMS) && !defined(_IEEE_FP)) || defined(_UNICOS) || defined(DOUBLE_IS_VAX_FLOAT)) && defined(NV_MAX_10_EXP)
1377 const NV exp_v = log10(value);
1378 if (exponent >= NV_MAX_10_EXP || exponent + exp_v >= NV_MAX_10_EXP)
1381 if (-(exponent + exp_v) >= NV_MAX_10_EXP)
1383 while (-exponent >= NV_MAX_10_EXP) {
1384 /* combination does not overflow, but 10^(-exponent) does */
1394 exponent = -exponent;
1395 #ifdef NV_MAX_10_EXP
1396 /* for something like 1234 x 10^-309, the action of calculating
1397 * the intermediate value 10^309 then returning 1234 / (10^309)
1398 * will fail, since 10^309 becomes infinity. In this case try to
1399 * refactor it as 123 / (10^308) etc.
1401 while (value && exponent > NV_MAX_10_EXP) {
1409 #if defined(__osf__)
1410 /* Even with cc -ieee + ieee_set_fp_control(IEEE_TRAP_ENABLE_INV)
1411 * Tru64 fp behavior on inf/nan is somewhat broken. Another way
1412 * to do this would be ieee_set_fp_control(IEEE_TRAP_ENABLE_OVF)
1413 * but that breaks another set of infnan.t tests. */
1414 # define FP_OVERFLOWS_TO_ZERO
1416 for (bit = 1; exponent; bit <<= 1) {
1417 if (exponent & bit) {
1420 #ifdef FP_OVERFLOWS_TO_ZERO
1423 return value < 0 ? -NV_INF : NV_INF;
1425 return value < 0 ? -FLT_MAX : FLT_MAX;
1428 /* Floating point exceptions are supposed to be turned off,
1429 * but if we're obviously done, don't risk another iteration.
1431 if (exponent == 0) break;
1435 return negative ? value / result : value * result;
1437 #endif /* #ifndef Perl_strtod */
1440 # define ATOF(s, x) my_atof2(s, &x)
1442 # define ATOF(s, x) Perl_atof2(s, x)
1446 Perl_my_atof(pTHX_ const char* s)
1448 /* 's' must be NUL terminated */
1452 PERL_ARGS_ASSERT_MY_ATOF;
1454 #if ! defined(USE_LOCALE_NUMERIC)
1461 DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
1462 STORE_LC_NUMERIC_SET_TO_NEEDED();
1463 if (! (PL_numeric_radix_sv && IN_LC(LC_NUMERIC))) {
1468 /* Look through the string for the first thing that looks like a
1469 * decimal point: either the value in the current locale or the
1470 * standard fallback of '.'. The one which appears earliest in the
1471 * input string is the one that we should have atof look for. Note
1472 * that we have to determine this beforehand because on some
1473 * systems, Perl_atof2 is just a wrapper around the system's atof.
1475 const char * const standard_pos = strchr(s, '.');
1476 const char * const local_pos
1477 = strstr(s, SvPV_nolen(PL_numeric_radix_sv));
1478 const bool use_standard_radix
1479 = standard_pos && (!local_pos || standard_pos < local_pos);
1481 if (use_standard_radix) {
1482 SET_NUMERIC_STANDARD();
1483 LOCK_LC_NUMERIC_STANDARD();
1488 if (use_standard_radix) {
1489 UNLOCK_LC_NUMERIC_STANDARD();
1490 SET_NUMERIC_UNDERLYING();
1493 RESTORE_LC_NUMERIC();
1501 #if defined(NV_INF) || defined(NV_NAN)
1504 S_my_atof_infnan(pTHX_ const char* s, bool negative, const char* send, NV* value)
1506 const char *p0 = negative ? s - 1 : s;
1508 const int infnan = grok_infnan(&p, send);
1509 if (infnan && p != p0) {
1510 /* If we can generate inf/nan directly, let's do so. */
1512 if ((infnan & IS_NUMBER_INFINITY)) {
1513 *value = (infnan & IS_NUMBER_NEG) ? -NV_INF: NV_INF;
1518 if ((infnan & IS_NUMBER_NAN)) {
1524 /* If still here, we didn't have either NV_INF or NV_NAN,
1525 * and can try falling back to native strtod/strtold.
1527 * The native interface might not recognize all the possible
1528 * inf/nan strings Perl recognizes. What we can try
1529 * is to try faking the input. We will try inf/-inf/nan
1530 * as the most promising/portable input. */
1532 const char* fake = "silence compiler warning";
1536 if ((infnan & IS_NUMBER_INFINITY)) {
1537 fake = ((infnan & IS_NUMBER_NEG)) ? "-inf" : "inf";
1541 if ((infnan & IS_NUMBER_NAN)) {
1545 assert(strNE(fake, "silence compiler warning"));
1546 nv = S_strtod(aTHX_ fake, &endp);
1549 if ((infnan & IS_NUMBER_INFINITY)) {
1554 /* last resort, may generate SIGFPE */
1555 *value = Perl_exp((NV)1e9);
1556 if ((infnan & IS_NUMBER_NEG))
1559 return (char*)p; /* p, not endp */
1563 if ((infnan & IS_NUMBER_NAN)) {
1568 /* last resort, may generate SIGFPE */
1569 *value = Perl_log((NV)-1.0);
1571 return (char*)p; /* p, not endp */
1576 #endif /* #ifdef Perl_strtod */
1581 #endif /* if defined(NV_INF) || defined(NV_NAN) */
1584 Perl_my_atof2(pTHX_ const char* orig, NV* value)
1586 PERL_ARGS_ASSERT_MY_ATOF2;
1587 return my_atof3(orig, value, 0);
1591 Perl_my_atof3(pTHX_ const char* orig, NV* value, const STRLEN len)
1593 const char* s = orig;
1594 NV result[3] = {0.0, 0.0, 0.0};
1595 #if defined(USE_PERL_ATOF) || defined(Perl_strtod)
1596 const char* send = s + ((len != 0)
1598 : strlen(orig)); /* one past the last */
1601 #if defined(USE_PERL_ATOF) && !defined(Perl_strtod)
1602 UV accumulator[2] = {0,0}; /* before/after dp */
1603 bool seen_digit = 0;
1604 I32 exp_adjust[2] = {0,0};
1605 I32 exp_acc[2] = {-1, -1};
1606 /* the current exponent adjust for the accumulators */
1611 I32 sig_digits = 0; /* noof significant digits seen so far */
1614 #if defined(USE_PERL_ATOF) || defined(Perl_strtod)
1615 PERL_ARGS_ASSERT_MY_ATOF3;
1617 /* leading whitespace */
1618 while (s < send && isSPACE(*s))
1636 if ((endp = S_my_atof_infnan(aTHX_ s, negative, send, value)))
1639 /* strtold() accepts 0x-prefixed hex and in POSIX implementations,
1640 0b-prefixed binary numbers, which is backward incompatible
1642 if ((len == 0 || len - (s-orig) >= 2) && *s == '0' &&
1643 (isALPHA_FOLD_EQ(s[1], 'x') || isALPHA_FOLD_EQ(s[1], 'b'))) {
1648 /* If the length is passed in, the input string isn't NUL-terminated,
1649 * and in it turns out the function below assumes it is; therefore we
1650 * create a copy and NUL-terminate that */
1652 Newx(copy, len + 1, char);
1653 Copy(orig, copy, len, char);
1655 s = copy + (s - orig);
1658 result[2] = S_strtod(aTHX_ s, &endp);
1660 /* If we created a copy, 'endp' is in terms of that. Convert back to
1663 s = (s - copy) + (char *) orig;
1664 endp = (endp - copy) + (char *) orig;
1669 *value = negative ? -result[2] : result[2];
1674 #elif defined(USE_PERL_ATOF)
1676 /* There is no point in processing more significant digits
1677 * than the NV can hold. Note that NV_DIG is a lower-bound value,
1678 * while we need an upper-bound value. We add 2 to account for this;
1679 * since it will have been conservative on both the first and last digit.
1680 * For example a 32-bit mantissa with an exponent of 4 would have
1681 * exact values in the set
1689 * where for the purposes of calculating NV_DIG we would have to discount
1690 * both the first and last digit, since neither can hold all values from
1691 * 0..9; but for calculating the value we must examine those two digits.
1693 #ifdef MAX_SIG_DIG_PLUS
1694 /* It is not necessarily the case that adding 2 to NV_DIG gets all the
1695 possible digits in a NV, especially if NVs are not IEEE compliant
1696 (e.g., long doubles on IRIX) - Allen <allens@cpan.org> */
1697 # define MAX_SIG_DIGITS (NV_DIG+MAX_SIG_DIG_PLUS)
1699 # define MAX_SIG_DIGITS (NV_DIG+2)
1702 /* the max number we can accumulate in a UV, and still safely do 10*N+9 */
1703 #define MAX_ACCUMULATE ( (UV) ((UV_MAX - 9)/10))
1705 #if defined(NV_INF) || defined(NV_NAN)
1708 if ((endp = S_my_atof_infnan(aTHX_ s, negative, send, value)))
1713 /* we accumulate digits into an integer; when this becomes too
1714 * large, we add the total to NV and start again */
1724 /* don't start counting until we see the first significant
1725 * digit, eg the 5 in 0.00005... */
1726 if (!sig_digits && digit == 0)
1729 if (++sig_digits > MAX_SIG_DIGITS) {
1730 /* limits of precision reached */
1732 ++accumulator[seen_dp];
1733 } else if (digit == 5) {
1734 if (old_digit % 2) { /* round to even - Allen */
1735 ++accumulator[seen_dp];
1743 /* skip remaining digits */
1744 while (s < send && isDIGIT(*s)) {
1750 /* warn of loss of precision? */
1753 if (accumulator[seen_dp] > MAX_ACCUMULATE) {
1754 /* add accumulator to result and start again */
1755 result[seen_dp] = S_mulexp10(result[seen_dp],
1757 + (NV)accumulator[seen_dp];
1758 accumulator[seen_dp] = 0;
1759 exp_acc[seen_dp] = 0;
1761 accumulator[seen_dp] = accumulator[seen_dp] * 10 + digit;
1765 else if (!seen_dp && GROK_NUMERIC_RADIX(&s, send)) {
1767 if (sig_digits > MAX_SIG_DIGITS) {
1768 while (s < send && isDIGIT(*s)) {
1779 result[0] = S_mulexp10(result[0], exp_acc[0]) + (NV)accumulator[0];
1781 result[1] = S_mulexp10(result[1], exp_acc[1]) + (NV)accumulator[1];
1784 if (s < send && seen_digit && (isALPHA_FOLD_EQ(*s, 'e'))) {
1785 bool expnegative = 0;
1795 while (s < send && isDIGIT(*s))
1796 exponent = exponent * 10 + (*s++ - '0');
1798 exponent = -exponent;
1801 /* now apply the exponent */
1804 result[2] = S_mulexp10(result[0],exponent+exp_adjust[0])
1805 + S_mulexp10(result[1],exponent-exp_adjust[1]);
1807 result[2] = S_mulexp10(result[0],exponent+exp_adjust[0]);
1810 /* now apply the sign */
1812 result[2] = -result[2];
1813 #endif /* USE_PERL_ATOF */
1819 =for apidoc isinfnan
1821 C<Perl_isinfnan()> is a utility function that returns true if the NV
1822 argument is either an infinity or a C<NaN>, false otherwise. To test
1823 in more detail, use C<Perl_isinf()> and C<Perl_isnan()>.
1825 This is also the logical inverse of Perl_isfinite().
1830 Perl_isinfnan(NV nv)
1832 PERL_UNUSED_ARG(nv);
1845 =for apidoc isinfnansv
1847 Checks whether the argument would be either an infinity or C<NaN> when used
1848 as a number, but is careful not to trigger non-numeric or uninitialized
1849 warnings. it assumes the caller has done C<SvGETMAGIC(sv)> already.
1855 Perl_isinfnansv(pTHX_ SV *sv)
1857 PERL_ARGS_ASSERT_ISINFNANSV;
1861 return Perl_isinfnan(SvNVX(sv));
1866 const char *s = SvPV_nomg_const(sv, len);
1867 return cBOOL(grok_infnan(&s, s+len));
1872 /* C99 has truncl, pre-C99 Solaris had aintl. We can use either with
1873 * copysignl to emulate modfl, which is in some platforms missing or
1875 # if defined(HAS_TRUNCL) && defined(HAS_COPYSIGNL)
1877 Perl_my_modfl(long double x, long double *ip)
1880 return (x == *ip ? copysignl(0.0L, x) : x - *ip);
1882 # elif defined(HAS_AINTL) && defined(HAS_COPYSIGNL)
1884 Perl_my_modfl(long double x, long double *ip)
1887 return (x == *ip ? copysignl(0.0L, x) : x - *ip);
1892 /* Similarly, with ilogbl and scalbnl we can emulate frexpl. */
1893 #if ! defined(HAS_FREXPL) && defined(HAS_ILOGBL) && defined(HAS_SCALBNL)
1895 Perl_my_frexpl(long double x, int *e) {
1896 *e = x == 0.0L ? 0 : ilogbl(x) + 1;
1897 return (scalbnl(x, -*e));
1902 =for apidoc Perl_signbit
1904 Return a non-zero integer if the sign bit on an NV is set, and 0 if
1907 If F<Configure> detects this system has a C<signbit()> that will work with
1908 our NVs, then we just use it via the C<#define> in F<perl.h>. Otherwise,
1909 fall back on this implementation. The main use of this function
1910 is catching C<-0.0>.
1912 C<Configure> notes: This function is called C<'Perl_signbit'> instead of a
1913 plain C<'signbit'> because it is easy to imagine a system having a C<signbit()>
1914 function or macro that doesn't happen to work with our particular choice
1915 of NVs. We shouldn't just re-C<#define> C<signbit> as C<Perl_signbit> and expect
1916 the standard system headers to be happy. Also, this is a no-context
1917 function (no C<pTHX_>) because C<Perl_signbit()> is usually re-C<#defined> in
1918 F<perl.h> as a simple macro call to the system's C<signbit()>.
1919 Users should just always call C<Perl_signbit()>.
1923 #if !defined(HAS_SIGNBIT)
1925 Perl_signbit(NV x) {
1926 # ifdef Perl_fp_class_nzero
1927 return Perl_fp_class_nzero(x);
1928 /* Try finding the high byte, and assume it's highest bit
1929 * is the sign. This assumption is probably wrong somewhere. */
1930 # elif defined(USE_LONG_DOUBLE) && LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_LITTLE_ENDIAN
1931 return (((unsigned char *)&x)[9] & 0x80);
1932 # elif defined(NV_LITTLE_ENDIAN)
1933 /* Note that NVSIZE is sizeof(NV), which would make the below be
1934 * wrong if the end bytes are unused, which happens with the x86
1935 * 80-bit long doubles, which is why take care of that above. */
1936 return (((unsigned char *)&x)[NVSIZE - 1] & 0x80);
1937 # elif defined(NV_BIG_ENDIAN)
1938 return (((unsigned char *)&x)[0] & 0x80);
1940 /* This last resort fallback is wrong for the negative zero. */
1941 return (x < 0.0) ? 1 : 0;
1947 * ex: set ts=8 sts=4 sw=4 et: