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
282 on this platform. But, C<*flags> will have the corresponding flag bit set.
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 8 digits are branchless except for the
427 * switch. A ninth one overflows a 32 bit word. */
432 if (UNLIKELY(! _generic_isCC(*s, class_bit))) break;
433 value = (value << shift) | XDIGIT_VALUE(*s);
437 if (UNLIKELY(! _generic_isCC(*s, class_bit))) break;
438 value = (value << shift) | XDIGIT_VALUE(*s);
442 if (UNLIKELY(! _generic_isCC(*s, class_bit))) break;
443 value = (value << shift) | XDIGIT_VALUE(*s);
447 if (UNLIKELY(! _generic_isCC(*s, class_bit))) break;
448 value = (value << shift) | XDIGIT_VALUE(*s);
452 if (UNLIKELY(! _generic_isCC(*s, class_bit))) break;
453 value = (value << shift) | XDIGIT_VALUE(*s);
457 if (UNLIKELY(! _generic_isCC(*s, class_bit))) break;
458 value = (value << shift) | XDIGIT_VALUE(*s);
462 if (UNLIKELY(! _generic_isCC(*s, class_bit))) break;
463 value = (value << shift) | XDIGIT_VALUE(*s);
467 if (UNLIKELY(! _generic_isCC(*s, class_bit))) break;
468 value = (value << shift) | XDIGIT_VALUE(*s);
470 if (LIKELY(len <= 8)) {
478 bytes_so_far = s - s0;
479 factor = shift << bytes_so_far;
483 if (_generic_isCC(*s, class_bit)) {
484 /* Write it in this wonky order with a goto to attempt to get the
485 compiler to make the common case integer-only loop pretty tight.
486 With gcc seems to be much straighter code than old scan_hex.
487 (khw suspects that adding a LIKELY() just above would do the
490 if (LIKELY(value <= max_div)) {
491 value = (value << shift) | XDIGIT_VALUE(*s);
492 /* Note XDIGIT_VALUE() is branchless, works on binary
493 * and octal as well, so can be used here, without
494 * slowing those down */
495 factor *= 1 << shift;
499 /* Bah. We are about to overflow. Instead, add the unoverflowed
500 * value to an NV that contains an approximation to the correct
501 * value. Each time through the loop we have increased 'factor' so
502 * that it gives how much the current approximation needs to
503 * effectively be shifted to make room for this new value */
505 value_nv += (NV) value;
507 /* Then we keep accumulating digits, until all are parsed. We
508 * start over using the current input value. This will be added to
509 * 'value_nv' eventually, either when all digits are gone, or we
510 * have overflowed this fresh start. */
511 value = XDIGIT_VALUE(*s);
516 if ( ! (input_flags & PERL_SCAN_SILENT_OVERFLOW)
517 && ckWARN_d(WARN_OVERFLOW))
519 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
520 "Integer overflow in %s number",
521 (base == 16) ? "hexadecimal"
533 && _generic_isCC(s[1], class_bit)
535 /* Don't allow a leading underscore if the only-medial bit is
538 || UNLIKELY((input_flags & PERL_SCAN_ALLOW_MEDIAL_UNDERSCORES)
539 != PERL_SCAN_ALLOW_MEDIAL_UNDERSCORES)))
547 if ( ! (input_flags & PERL_SCAN_SILENT_ILLDIGIT)
548 && ckWARN(WARN_DIGIT))
551 Perl_warner(aTHX_ packWARN(WARN_DIGIT),
552 "Illegal %s digit '%c' ignored",
558 else if (isDIGIT(*s)) { /* octal base */
560 /* Allow \octal to work the DWIM way (that is, stop
561 * scanning as soon as non-octal characters are seen,
562 * complain only if someone seems to want to use the digits
563 * eight and nine. Since we know it is not octal, then if
564 * isDIGIT, must be an 8 or 9). */
565 Perl_warner(aTHX_ packWARN(WARN_DIGIT),
566 "Illegal octal digit '%c' ignored", *s);
570 if (input_flags & PERL_SCAN_NOTIFY_ILLDIGIT) {
571 *flags |= PERL_SCAN_NOTIFY_ILLDIGIT;
580 if (LIKELY(! overflowed)) {
582 if ( UNLIKELY(value > 0xffffffff)
583 && ! (input_flags & PERL_SCAN_SILENT_NON_PORTABLE))
585 output_non_portable(base);
586 *flags |= PERL_SCAN_SILENT_NON_PORTABLE;
592 /* Overflowed: Calculate the final overflow approximation */
594 value_nv += (NV) value;
596 output_non_portable(base);
598 *flags |= PERL_SCAN_GREATER_THAN_UV_MAX
599 | PERL_SCAN_SILENT_NON_PORTABLE;
608 For backwards compatibility. Use C<grok_bin> instead.
612 For backwards compatibility. Use C<grok_hex> instead.
616 For backwards compatibility. Use C<grok_oct> instead.
622 Perl_scan_bin(pTHX_ const char *start, STRLEN len, STRLEN *retlen)
625 I32 flags = *retlen ? PERL_SCAN_ALLOW_UNDERSCORES : 0;
626 const UV ruv = grok_bin (start, &len, &flags, &rnv);
628 PERL_ARGS_ASSERT_SCAN_BIN;
631 return (flags & PERL_SCAN_GREATER_THAN_UV_MAX) ? rnv : (NV)ruv;
635 Perl_scan_oct(pTHX_ const char *start, STRLEN len, STRLEN *retlen)
638 I32 flags = *retlen ? PERL_SCAN_ALLOW_UNDERSCORES : 0;
639 const UV ruv = grok_oct (start, &len, &flags, &rnv);
641 PERL_ARGS_ASSERT_SCAN_OCT;
644 return (flags & PERL_SCAN_GREATER_THAN_UV_MAX) ? rnv : (NV)ruv;
648 Perl_scan_hex(pTHX_ const char *start, STRLEN len, STRLEN *retlen)
651 I32 flags = *retlen ? PERL_SCAN_ALLOW_UNDERSCORES : 0;
652 const UV ruv = grok_hex (start, &len, &flags, &rnv);
654 PERL_ARGS_ASSERT_SCAN_HEX;
657 return (flags & PERL_SCAN_GREATER_THAN_UV_MAX) ? rnv : (NV)ruv;
661 =for apidoc grok_numeric_radix
663 Scan and skip for a numeric decimal separator (radix).
668 Perl_grok_numeric_radix(pTHX_ const char **sp, const char *send)
670 PERL_ARGS_ASSERT_GROK_NUMERIC_RADIX;
672 #ifdef USE_LOCALE_NUMERIC
674 if (IN_LC(LC_NUMERIC)) {
677 bool matches_radix = FALSE;
678 DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
680 STORE_LC_NUMERIC_FORCE_TO_UNDERLYING();
682 radix = SvPV(PL_numeric_radix_sv, len);
683 radix = savepvn(radix, len);
685 RESTORE_LC_NUMERIC();
687 if (*sp + len <= send) {
688 matches_radix = memEQ(*sp, radix, len);
701 /* always try "." if numeric radix didn't match because
702 * we may have data from different locales mixed */
703 if (*sp < send && **sp == '.') {
712 =for apidoc grok_infnan
714 Helper for C<grok_number()>, accepts various ways of spelling "infinity"
715 or "not a number", and returns one of the following flag combinations:
719 IS_NUMBER_INFINITY | IS_NUMBER_NEG
720 IS_NUMBER_NAN | IS_NUMBER_NEG
723 possibly |-ed with C<IS_NUMBER_TRAILING>.
725 If an infinity or a not-a-number is recognized, C<*sp> will point to
726 one byte past the end of the recognized string. If the recognition fails,
727 zero is returned, and C<*sp> will not move.
729 =for apidoc Amn|bool|IS_NUMBER_GREATER_THAN_UV_MAX
730 =for apidoc Amn|bool|IS_NUMBER_INFINITY
731 =for apidoc Amn|bool|IS_NUMBER_IN_UV
732 =for apidoc Amn|bool|IS_NUMBER_NAN
733 =for apidoc Amn|bool|IS_NUMBER_NEG
734 =for apidoc Amn|bool|IS_NUMBER_NOT_INT
740 Perl_grok_infnan(pTHX_ const char** sp, const char* send)
744 #if defined(NV_INF) || defined(NV_NAN)
745 bool odh = FALSE; /* one-dot-hash: 1.#INF */
747 PERL_ARGS_ASSERT_GROK_INFNAN;
750 s++; if (s == send) return 0;
752 else if (*s == '-') {
753 flags |= IS_NUMBER_NEG; /* Yes, -NaN happens. Incorrect but happens. */
754 s++; if (s == send) return 0;
758 /* Visual C: 1.#SNAN, -1.#QNAN, 1#INF, 1.#IND (maybe also 1.#NAN)
759 * Let's keep the dot optional. */
760 s++; if (s == send) return 0;
762 s++; if (s == send) return 0;
765 s++; if (s == send) return 0;
771 if (isALPHA_FOLD_EQ(*s, 'I')) {
772 /* INF or IND (1.#IND is "indeterminate", a certain type of NAN) */
774 s++; if (s == send || isALPHA_FOLD_NE(*s, 'N')) return 0;
775 s++; if (s == send) return 0;
776 if (isALPHA_FOLD_EQ(*s, 'F')) {
778 if (s < send && (isALPHA_FOLD_EQ(*s, 'I'))) {
780 flags | IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT | IS_NUMBER_TRAILING;
781 s++; if (s == send || isALPHA_FOLD_NE(*s, 'N')) return fail;
782 s++; if (s == send || isALPHA_FOLD_NE(*s, 'I')) return fail;
783 s++; if (s == send || isALPHA_FOLD_NE(*s, 'T')) return fail;
784 s++; if (s == send || isALPHA_FOLD_NE(*s, 'Y')) return fail;
787 while (*s == '0') { /* 1.#INF00 */
791 while (s < send && isSPACE(*s))
793 if (s < send && *s) {
794 flags |= IS_NUMBER_TRAILING;
796 flags |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT;
798 else if (isALPHA_FOLD_EQ(*s, 'D') && odh) { /* 1.#IND */
800 flags |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT;
801 while (*s == '0') { /* 1.#IND00 */
805 flags |= IS_NUMBER_TRAILING;
811 /* Maybe NAN of some sort */
813 if (isALPHA_FOLD_EQ(*s, 'S') || isALPHA_FOLD_EQ(*s, 'Q')) {
815 /* XXX do something with the snan/qnan difference */
816 s++; if (s == send) return 0;
819 if (isALPHA_FOLD_EQ(*s, 'N')) {
820 s++; if (s == send || isALPHA_FOLD_NE(*s, 'A')) return 0;
821 s++; if (s == send || isALPHA_FOLD_NE(*s, 'N')) return 0;
824 flags |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT;
829 /* NaN can be followed by various stuff (NaNQ, NaNS), but
830 * there are also multiple different NaN values, and some
831 * implementations output the "payload" values,
832 * e.g. NaN123, NAN(abc), while some legacy implementations
833 * have weird stuff like NaN%. */
834 if (isALPHA_FOLD_EQ(*s, 'q') ||
835 isALPHA_FOLD_EQ(*s, 's')) {
836 /* "nanq" or "nans" are ok, though generating
837 * these portably is tricky. */
844 /* C99 style "nan(123)" or Perlish equivalent "nan($uv)". */
848 return flags | IS_NUMBER_TRAILING;
851 while (t < send && *t && *t != ')') {
855 return flags | IS_NUMBER_TRAILING;
860 if (s[0] == '0' && s + 2 < t &&
861 isALPHA_FOLD_EQ(s[1], 'x') &&
864 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
865 nanval = grok_hex(s, &len, &flags, NULL);
866 if ((flags & PERL_SCAN_GREATER_THAN_UV_MAX)) {
869 nantype = IS_NUMBER_IN_UV;
872 } else if (s[0] == '0' && s + 2 < t &&
873 isALPHA_FOLD_EQ(s[1], 'b') &&
874 (s[2] == '0' || s[2] == '1')) {
876 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
877 nanval = grok_bin(s, &len, &flags, NULL);
878 if ((flags & PERL_SCAN_GREATER_THAN_UV_MAX)) {
881 nantype = IS_NUMBER_IN_UV;
887 grok_number_flags(s, t - s, &nanval,
889 PERL_SCAN_ALLOW_UNDERSCORES);
890 /* Unfortunately grok_number_flags() doesn't
891 * tell how far we got and the ')' will always
892 * be "trailing", so we need to double-check
893 * whether we had something dubious. */
894 for (u = s; u < t; u++) {
896 flags |= IS_NUMBER_TRAILING;
903 /* XXX Doesn't do octal: nan("0123").
904 * Probably not a big loss. */
906 if ((nantype & IS_NUMBER_NOT_INT) ||
907 !(nantype && IS_NUMBER_IN_UV)) {
908 /* XXX the nanval is currently unused, that is,
909 * not inserted as the NaN payload of the NV.
910 * But the above code already parses the C99
911 * nan(...) format. See below, and see also
912 * the nan() in POSIX.xs.
914 * Certain configuration combinations where
915 * NVSIZE is greater than UVSIZE mean that
916 * a single UV cannot contain all the possible
917 * NaN payload bits. There would need to be
918 * some more generic syntax than "nan($uv)".
920 * Issues to keep in mind:
922 * (1) In most common cases there would
923 * not be an integral number of bytes that
924 * could be set, only a certain number of bits.
925 * For example for the common case of
926 * NVSIZE == UVSIZE == 8 there is room for 52
927 * bits in the payload, but the most significant
928 * bit is commonly reserved for the
929 * signaling/quiet bit, leaving 51 bits.
930 * Furthermore, the C99 nan() is supposed
931 * to generate quiet NaNs, so it is doubtful
932 * whether it should be able to generate
933 * signaling NaNs. For the x86 80-bit doubles
934 * (if building a long double Perl) there would
935 * be 62 bits (s/q bit being the 63rd).
937 * (2) Endianness of the payload bits. If the
938 * payload is specified as an UV, the low-order
939 * bits of the UV are naturally little-endianed
940 * (rightmost) bits of the payload. The endianness
941 * of UVs and NVs can be different. */
945 flags |= IS_NUMBER_TRAILING;
948 /* Looked like nan(...), but no close paren. */
949 flags |= IS_NUMBER_TRAILING;
952 while (s < send && isSPACE(*s))
954 if (s < send && *s) {
955 /* Note that we here implicitly accept (parse as
956 * "nan", but with warnings) also any other weird
957 * trailing stuff for "nan". In the above we just
958 * check that if we got the C99-style "nan(...)",
959 * the "..." looks sane.
960 * If in future we accept more ways of specifying
961 * the nan payload, the accepting would happen around
963 flags |= IS_NUMBER_TRAILING;
972 while (s < send && isSPACE(*s))
976 PERL_UNUSED_ARG(send);
977 #endif /* #if defined(NV_INF) || defined(NV_NAN) */
983 =for apidoc grok_number_flags
985 Recognise (or not) a number. The type of the number is returned
986 (0 if unrecognised), otherwise it is a bit-ORed combination of
987 C<IS_NUMBER_IN_UV>, C<IS_NUMBER_GREATER_THAN_UV_MAX>, C<IS_NUMBER_NOT_INT>,
988 C<IS_NUMBER_NEG>, C<IS_NUMBER_INFINITY>, C<IS_NUMBER_NAN> (defined in perl.h).
990 If the value of the number can fit in a UV, it is returned in C<*valuep>.
991 C<IS_NUMBER_IN_UV> will be set to indicate that C<*valuep> is valid, C<IS_NUMBER_IN_UV>
992 will never be set unless C<*valuep> is valid, but C<*valuep> may have been assigned
993 to during processing even though C<IS_NUMBER_IN_UV> is not set on return.
994 If C<valuep> is C<NULL>, C<IS_NUMBER_IN_UV> will be set for the same cases as when
995 C<valuep> is non-C<NULL>, but no actual assignment (or SEGV) will occur.
997 C<IS_NUMBER_NOT_INT> will be set with C<IS_NUMBER_IN_UV> if trailing decimals were
998 seen (in which case C<*valuep> gives the true value truncated to an integer), and
999 C<IS_NUMBER_NEG> if the number is negative (in which case C<*valuep> holds the
1000 absolute value). C<IS_NUMBER_IN_UV> is not set if e notation was used or the
1001 number is larger than a UV.
1003 C<flags> allows only C<PERL_SCAN_TRAILING>, which allows for trailing
1004 non-numeric text on an otherwise successful I<grok>, setting
1005 C<IS_NUMBER_TRAILING> on the result.
1007 =for apidoc Amnh||PERL_SCAN_TRAILING
1009 =for apidoc grok_number
1011 Identical to C<grok_number_flags()> with C<flags> set to zero.
1016 Perl_grok_number(pTHX_ const char *pv, STRLEN len, UV *valuep)
1018 PERL_ARGS_ASSERT_GROK_NUMBER;
1020 return grok_number_flags(pv, len, valuep, 0);
1023 static const UV uv_max_div_10 = UV_MAX / 10;
1024 static const U8 uv_max_mod_10 = UV_MAX % 10;
1027 Perl_grok_number_flags(pTHX_ const char *pv, STRLEN len, UV *valuep, U32 flags)
1030 const char * const send = pv + len;
1034 PERL_ARGS_ASSERT_GROK_NUMBER_FLAGS;
1036 if (UNLIKELY(isSPACE(*s))) {
1039 if (LIKELY(! isSPACE(*s))) goto non_space;
1046 /* See if signed. This assumes it is more likely to be unsigned, so
1047 * penalizes signed by an extra conditional; rewarding unsigned by one fewer
1048 * (because we detect '+' and '-' with a single test and then add a
1049 * conditional to determine which) */
1050 if (UNLIKELY((*s & ~('+' ^ '-')) == ('+' & '-') )) {
1052 /* Here, on ASCII platforms, *s is one of: 0x29 = ')', 2B = '+', 2D = '-',
1053 * 2F = '/'. That is, it is either a sign, or a character that doesn't
1054 * belong in a number at all (unless it's a radix character in a weird
1055 * locale). Given this, it's far more likely to be a minus than the
1056 * others. (On EBCDIC it is one of 42, 44, 46, 48, 4A, 4C, 4E, (not 40
1057 * because can't be a space) 60, 62, 64, 66, 68, 6A, 6C, 6E. Again,
1058 * only potentially a weird radix character, or 4E='+', or 60='-') */
1059 if (LIKELY(*s == '-')) {
1061 numtype = IS_NUMBER_NEG;
1063 else if (LIKELY(*s == '+'))
1065 else /* Can't just return failure here, as it could be a weird radix
1069 if (UNLIKELY(s == send))
1074 /* The first digit (after optional sign): note that might
1075 * also point to "infinity" or "nan", or "1.#INF". */
1078 /* next must be digit or the radix separator or beginning of infinity/nan */
1079 if (LIKELY(isDIGIT(*s))) {
1080 /* UVs are at least 32 bits, so the first 9 decimal digits cannot
1082 UV value = *s - '0'; /* Process this first (perhaps only) digit */
1088 default: /* 8 or more remaining characters */
1090 if (UNLIKELY(! inRANGE(digit, 0, 9))) break;
1091 value = value * 10 + digit;
1096 if (UNLIKELY(! inRANGE(digit, 0, 9))) break;
1097 value = value * 10 + digit;
1102 if (UNLIKELY(! inRANGE(digit, 0, 9))) break;
1103 value = value * 10 + digit;
1108 if (UNLIKELY(! inRANGE(digit, 0, 9))) break;
1109 value = value * 10 + digit;
1114 if (UNLIKELY(! inRANGE(digit, 0, 9))) break;
1115 value = value * 10 + digit;
1120 if (UNLIKELY(! inRANGE(digit, 0, 9))) break;
1121 value = value * 10 + digit;
1126 if (UNLIKELY(! inRANGE(digit, 0, 9))) break;
1127 value = value * 10 + digit;
1132 if (UNLIKELY(! inRANGE(digit, 0, 9))) break;
1133 value = value * 10 + digit;
1136 case 0: /* This case means the string consists of just the one
1137 digit we already have processed */
1139 /* If we got here by falling through other than the default: case, we
1140 * have processed the whole string, and know it consists entirely of
1141 * digits, and can't have overflowed. */
1145 return numtype|IS_NUMBER_IN_UV;
1148 /* Here, there are extra characters beyond the first 9 digits. Use a
1149 * loop to accumulate any remaining digits, until we get a non-digit or
1150 * would overflow. Note that leading zeros could cause us to get here
1151 * without being close to overflowing.
1153 * (The conditional 's >= send' above could be eliminated by making the
1154 * default: in the switch to instead be 'case 8:', and process longer
1155 * strings separately by using the loop below. This would penalize
1156 * these inputs by the extra instructions needed for looping. That
1157 * could be eliminated by copying the unwound code from above to handle
1158 * the firt 9 digits of these. khw didn't think this saving of a
1159 * single conditional was worth it.) */
1162 if (! inRANGE(digit, 0, 9)) goto mantissa_done;
1163 if ( value < uv_max_div_10
1164 || ( value == uv_max_div_10
1165 && digit <= uv_max_mod_10))
1167 value = value * 10 + digit;
1170 else { /* value would overflow. skip the remaining digits, don't
1171 worry about setting *valuep. */
1174 } while (s < send && isDIGIT(*s));
1176 IS_NUMBER_GREATER_THAN_UV_MAX;
1180 } /* End switch on input length */
1183 numtype |= IS_NUMBER_IN_UV;
1188 if (GROK_NUMERIC_RADIX(&s, send)) {
1189 numtype |= IS_NUMBER_NOT_INT;
1190 while (s < send && isDIGIT(*s)) /* optional digits after the radix */
1193 } /* End of *s is a digit */
1194 else if (GROK_NUMERIC_RADIX(&s, send)) {
1195 numtype |= IS_NUMBER_NOT_INT | IS_NUMBER_IN_UV; /* valuep assigned below */
1196 /* no digits before the radix means we need digits after it */
1197 if (s < send && isDIGIT(*s)) {
1200 } while (s < send && isDIGIT(*s));
1202 /* integer approximation is valid - it's 0. */
1210 if (LIKELY(s > d) && s < send) {
1211 /* we can have an optional exponent part */
1212 if (UNLIKELY(isALPHA_FOLD_EQ(*s, 'e'))) {
1214 if (s < send && (*s == '-' || *s == '+'))
1216 if (s < send && isDIGIT(*s)) {
1219 } while (s < send && isDIGIT(*s));
1221 else if (flags & PERL_SCAN_TRAILING)
1222 return numtype | IS_NUMBER_TRAILING;
1226 /* The only flag we keep is sign. Blow away any "it's UV" */
1227 numtype &= IS_NUMBER_NEG;
1228 numtype |= IS_NUMBER_NOT_INT;
1233 if (LIKELY(! isSPACE(*s))) goto end_space;
1240 if (UNLIKELY(memEQs(pv, len, "0 but true"))) {
1243 return IS_NUMBER_IN_UV;
1246 /* We could be e.g. at "Inf" or "NaN", or at the "#" of "1.#INF". */
1247 if ((s + 2 < send) && UNLIKELY(memCHRs("inqs#", toFOLD(*s)))) {
1248 /* Really detect inf/nan. Start at d, not s, since the above
1249 * code might have already consumed the "1." or "1". */
1250 const int infnan = Perl_grok_infnan(aTHX_ &d, send);
1251 if ((infnan & IS_NUMBER_INFINITY)) {
1252 return (numtype | infnan); /* Keep sign for infinity. */
1254 else if ((infnan & IS_NUMBER_NAN)) {
1255 return (numtype | infnan) & ~IS_NUMBER_NEG; /* Clear sign for nan. */
1258 else if (flags & PERL_SCAN_TRAILING) {
1259 return numtype | IS_NUMBER_TRAILING;
1266 =for apidoc grok_atoUV
1268 parse a string, looking for a decimal unsigned integer.
1270 On entry, C<pv> points to the beginning of the string;
1271 C<valptr> points to a UV that will receive the converted value, if found;
1272 C<endptr> is either NULL or points to a variable that points to one byte
1273 beyond the point in C<pv> that this routine should examine.
1274 If C<endptr> is NULL, C<pv> is assumed to be NUL-terminated.
1276 Returns FALSE if C<pv> doesn't represent a valid unsigned integer value (with
1277 no leading zeros). Otherwise it returns TRUE, and sets C<*valptr> to that
1280 If you constrain the portion of C<pv> that is looked at by this function (by
1281 passing a non-NULL C<endptr>), and if the intial bytes of that portion form a
1282 valid value, it will return TRUE, setting C<*endptr> to the byte following the
1283 final digit of the value. But if there is no constraint at what's looked at,
1284 all of C<pv> must be valid in order for TRUE to be returned.
1286 The only characters this accepts are the decimal digits '0'..'9'.
1288 As opposed to L<atoi(3)> or L<strtol(3)>, C<grok_atoUV> does NOT allow optional
1289 leading whitespace, nor negative inputs. If such features are required, the
1290 calling code needs to explicitly implement those.
1292 Note that this function returns FALSE for inputs that would overflow a UV,
1293 or have leading zeros. Thus a single C<0> is accepted, but not C<00> nor
1294 C<01>, C<002>, I<etc>.
1296 Background: C<atoi> has severe problems with illegal inputs, it cannot be
1297 used for incremental parsing, and therefore should be avoided
1298 C<atoi> and C<strtol> are also affected by locale settings, which can also be
1299 seen as a bug (global state controlled by user environment).
1306 Perl_grok_atoUV(const char *pv, UV *valptr, const char** endptr)
1310 const char* end2; /* Used in case endptr is NULL. */
1311 UV val = 0; /* The parsed value. */
1313 PERL_ARGS_ASSERT_GROK_ATOUV;
1319 end2 = s + strlen(s);
1329 /* Single-digit inputs are quite common. */
1331 if (s < *eptr && isDIGIT(*s)) {
1332 /* Fail on extra leading zeros. */
1335 while (s < *eptr && isDIGIT(*s)) {
1336 /* This could be unrolled like in grok_number(), but
1337 * the expected uses of this are not speed-needy, and
1338 * unlikely to need full 64-bitness. */
1339 const U8 digit = *s++ - '0';
1340 if (val < uv_max_div_10 ||
1341 (val == uv_max_div_10 && digit <= uv_max_mod_10)) {
1342 val = val * 10 + digit;
1349 if (endptr == NULL) {
1351 return FALSE; /* If endptr is NULL, no trailing non-digits allowed. */
1364 S_mulexp10(NV value, I32 exponent)
1376 /* On OpenVMS VAX we by default use the D_FLOAT double format,
1377 * and that format does not have *easy* capabilities [1] for
1378 * overflowing doubles 'silently' as IEEE fp does. We also need
1379 * to support G_FLOAT on both VAX and Alpha, and though the exponent
1380 * range is much larger than D_FLOAT it still doesn't do silent
1381 * overflow. Therefore we need to detect early whether we would
1382 * overflow (this is the behaviour of the native string-to-float
1383 * conversion routines, and therefore of native applications, too).
1385 * [1] Trying to establish a condition handler to trap floating point
1386 * exceptions is not a good idea. */
1388 /* In UNICOS and in certain Cray models (such as T90) there is no
1389 * IEEE fp, and no way at all from C to catch fp overflows gracefully.
1390 * There is something you can do if you are willing to use some
1391 * inline assembler: the instruction is called DFI-- but that will
1392 * disable *all* floating point interrupts, a little bit too large
1393 * a hammer. Therefore we need to catch potential overflows before
1396 #if ((defined(VMS) && !defined(_IEEE_FP)) || defined(_UNICOS) || defined(DOUBLE_IS_VAX_FLOAT)) && defined(NV_MAX_10_EXP)
1398 const NV exp_v = log10(value);
1399 if (exponent >= NV_MAX_10_EXP || exponent + exp_v >= NV_MAX_10_EXP)
1402 if (-(exponent + exp_v) >= NV_MAX_10_EXP)
1404 while (-exponent >= NV_MAX_10_EXP) {
1405 /* combination does not overflow, but 10^(-exponent) does */
1415 exponent = -exponent;
1416 #ifdef NV_MAX_10_EXP
1417 /* for something like 1234 x 10^-309, the action of calculating
1418 * the intermediate value 10^309 then returning 1234 / (10^309)
1419 * will fail, since 10^309 becomes infinity. In this case try to
1420 * refactor it as 123 / (10^308) etc.
1422 while (value && exponent > NV_MAX_10_EXP) {
1430 #if defined(__osf__)
1431 /* Even with cc -ieee + ieee_set_fp_control(IEEE_TRAP_ENABLE_INV)
1432 * Tru64 fp behavior on inf/nan is somewhat broken. Another way
1433 * to do this would be ieee_set_fp_control(IEEE_TRAP_ENABLE_OVF)
1434 * but that breaks another set of infnan.t tests. */
1435 # define FP_OVERFLOWS_TO_ZERO
1437 for (bit = 1; exponent; bit <<= 1) {
1438 if (exponent & bit) {
1441 #ifdef FP_OVERFLOWS_TO_ZERO
1444 return value < 0 ? -NV_INF : NV_INF;
1446 return value < 0 ? -FLT_MAX : FLT_MAX;
1449 /* Floating point exceptions are supposed to be turned off,
1450 * but if we're obviously done, don't risk another iteration.
1452 if (exponent == 0) break;
1456 return negative ? value / result : value * result;
1458 #endif /* #ifndef Perl_strtod */
1461 # define ATOF(s, x) my_atof2(s, &x)
1463 # define ATOF(s, x) Perl_atof2(s, x)
1467 Perl_my_atof(pTHX_ const char* s)
1469 /* 's' must be NUL terminated */
1473 PERL_ARGS_ASSERT_MY_ATOF;
1475 #if ! defined(USE_LOCALE_NUMERIC)
1482 DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
1483 STORE_LC_NUMERIC_SET_TO_NEEDED();
1484 if (! (PL_numeric_radix_sv && IN_LC(LC_NUMERIC))) {
1489 /* Look through the string for the first thing that looks like a
1490 * decimal point: either the value in the current locale or the
1491 * standard fallback of '.'. The one which appears earliest in the
1492 * input string is the one that we should have atof look for. Note
1493 * that we have to determine this beforehand because on some
1494 * systems, Perl_atof2 is just a wrapper around the system's atof.
1496 const char * const standard_pos = strchr(s, '.');
1497 const char * const local_pos
1498 = strstr(s, SvPV_nolen(PL_numeric_radix_sv));
1499 const bool use_standard_radix
1500 = standard_pos && (!local_pos || standard_pos < local_pos);
1502 if (use_standard_radix) {
1503 SET_NUMERIC_STANDARD();
1504 LOCK_LC_NUMERIC_STANDARD();
1509 if (use_standard_radix) {
1510 UNLOCK_LC_NUMERIC_STANDARD();
1511 SET_NUMERIC_UNDERLYING();
1514 RESTORE_LC_NUMERIC();
1522 #if defined(NV_INF) || defined(NV_NAN)
1525 S_my_atof_infnan(pTHX_ const char* s, bool negative, const char* send, NV* value)
1527 const char *p0 = negative ? s - 1 : s;
1529 const int infnan = grok_infnan(&p, send);
1530 if (infnan && p != p0) {
1531 /* If we can generate inf/nan directly, let's do so. */
1533 if ((infnan & IS_NUMBER_INFINITY)) {
1534 *value = (infnan & IS_NUMBER_NEG) ? -NV_INF: NV_INF;
1539 if ((infnan & IS_NUMBER_NAN)) {
1545 /* If still here, we didn't have either NV_INF or NV_NAN,
1546 * and can try falling back to native strtod/strtold.
1548 * The native interface might not recognize all the possible
1549 * inf/nan strings Perl recognizes. What we can try
1550 * is to try faking the input. We will try inf/-inf/nan
1551 * as the most promising/portable input. */
1553 const char* fake = "silence compiler warning";
1557 if ((infnan & IS_NUMBER_INFINITY)) {
1558 fake = ((infnan & IS_NUMBER_NEG)) ? "-inf" : "inf";
1562 if ((infnan & IS_NUMBER_NAN)) {
1566 assert(strNE(fake, "silence compiler warning"));
1567 nv = S_strtod(aTHX_ fake, &endp);
1570 if ((infnan & IS_NUMBER_INFINITY)) {
1575 /* last resort, may generate SIGFPE */
1576 *value = Perl_exp((NV)1e9);
1577 if ((infnan & IS_NUMBER_NEG))
1580 return (char*)p; /* p, not endp */
1584 if ((infnan & IS_NUMBER_NAN)) {
1589 /* last resort, may generate SIGFPE */
1590 *value = Perl_log((NV)-1.0);
1592 return (char*)p; /* p, not endp */
1597 #endif /* #ifdef Perl_strtod */
1602 #endif /* if defined(NV_INF) || defined(NV_NAN) */
1605 Perl_my_atof2(pTHX_ const char* orig, NV* value)
1607 PERL_ARGS_ASSERT_MY_ATOF2;
1608 return my_atof3(orig, value, 0);
1612 Perl_my_atof3(pTHX_ const char* orig, NV* value, const STRLEN len)
1614 const char* s = orig;
1615 NV result[3] = {0.0, 0.0, 0.0};
1616 #if defined(USE_PERL_ATOF) || defined(Perl_strtod)
1617 const char* send = s + ((len != 0)
1619 : strlen(orig)); /* one past the last */
1622 #if defined(USE_PERL_ATOF) && !defined(Perl_strtod)
1623 UV accumulator[2] = {0,0}; /* before/after dp */
1624 bool seen_digit = 0;
1625 I32 exp_adjust[2] = {0,0};
1626 I32 exp_acc[2] = {-1, -1};
1627 /* the current exponent adjust for the accumulators */
1632 I32 sig_digits = 0; /* noof significant digits seen so far */
1635 #if defined(USE_PERL_ATOF) || defined(Perl_strtod)
1636 PERL_ARGS_ASSERT_MY_ATOF3;
1638 /* leading whitespace */
1639 while (s < send && isSPACE(*s))
1657 if ((endp = S_my_atof_infnan(aTHX_ s, negative, send, value)))
1660 /* strtold() accepts 0x-prefixed hex and in POSIX implementations,
1661 0b-prefixed binary numbers, which is backward incompatible
1663 if ((len == 0 || len - (s-orig) >= 2) && *s == '0' &&
1664 (isALPHA_FOLD_EQ(s[1], 'x') || isALPHA_FOLD_EQ(s[1], 'b'))) {
1669 /* If the length is passed in, the input string isn't NUL-terminated,
1670 * and in it turns out the function below assumes it is; therefore we
1671 * create a copy and NUL-terminate that */
1673 Newx(copy, len + 1, char);
1674 Copy(orig, copy, len, char);
1676 s = copy + (s - orig);
1679 result[2] = S_strtod(aTHX_ s, &endp);
1681 /* If we created a copy, 'endp' is in terms of that. Convert back to
1684 s = (s - copy) + (char *) orig;
1685 endp = (endp - copy) + (char *) orig;
1690 *value = negative ? -result[2] : result[2];
1695 #elif defined(USE_PERL_ATOF)
1697 /* There is no point in processing more significant digits
1698 * than the NV can hold. Note that NV_DIG is a lower-bound value,
1699 * while we need an upper-bound value. We add 2 to account for this;
1700 * since it will have been conservative on both the first and last digit.
1701 * For example a 32-bit mantissa with an exponent of 4 would have
1702 * exact values in the set
1710 * where for the purposes of calculating NV_DIG we would have to discount
1711 * both the first and last digit, since neither can hold all values from
1712 * 0..9; but for calculating the value we must examine those two digits.
1714 #ifdef MAX_SIG_DIG_PLUS
1715 /* It is not necessarily the case that adding 2 to NV_DIG gets all the
1716 possible digits in a NV, especially if NVs are not IEEE compliant
1717 (e.g., long doubles on IRIX) - Allen <allens@cpan.org> */
1718 # define MAX_SIG_DIGITS (NV_DIG+MAX_SIG_DIG_PLUS)
1720 # define MAX_SIG_DIGITS (NV_DIG+2)
1723 /* the max number we can accumulate in a UV, and still safely do 10*N+9 */
1724 #define MAX_ACCUMULATE ( (UV) ((UV_MAX - 9)/10))
1726 #if defined(NV_INF) || defined(NV_NAN)
1729 if ((endp = S_my_atof_infnan(aTHX_ s, negative, send, value)))
1734 /* we accumulate digits into an integer; when this becomes too
1735 * large, we add the total to NV and start again */
1745 /* don't start counting until we see the first significant
1746 * digit, eg the 5 in 0.00005... */
1747 if (!sig_digits && digit == 0)
1750 if (++sig_digits > MAX_SIG_DIGITS) {
1751 /* limits of precision reached */
1753 ++accumulator[seen_dp];
1754 } else if (digit == 5) {
1755 if (old_digit % 2) { /* round to even - Allen */
1756 ++accumulator[seen_dp];
1764 /* skip remaining digits */
1765 while (s < send && isDIGIT(*s)) {
1771 /* warn of loss of precision? */
1774 if (accumulator[seen_dp] > MAX_ACCUMULATE) {
1775 /* add accumulator to result and start again */
1776 result[seen_dp] = S_mulexp10(result[seen_dp],
1778 + (NV)accumulator[seen_dp];
1779 accumulator[seen_dp] = 0;
1780 exp_acc[seen_dp] = 0;
1782 accumulator[seen_dp] = accumulator[seen_dp] * 10 + digit;
1786 else if (!seen_dp && GROK_NUMERIC_RADIX(&s, send)) {
1788 if (sig_digits > MAX_SIG_DIGITS) {
1789 while (s < send && isDIGIT(*s)) {
1800 result[0] = S_mulexp10(result[0], exp_acc[0]) + (NV)accumulator[0];
1802 result[1] = S_mulexp10(result[1], exp_acc[1]) + (NV)accumulator[1];
1805 if (s < send && seen_digit && (isALPHA_FOLD_EQ(*s, 'e'))) {
1806 bool expnegative = 0;
1816 while (s < send && isDIGIT(*s))
1817 exponent = exponent * 10 + (*s++ - '0');
1819 exponent = -exponent;
1822 /* now apply the exponent */
1825 result[2] = S_mulexp10(result[0],exponent+exp_adjust[0])
1826 + S_mulexp10(result[1],exponent-exp_adjust[1]);
1828 result[2] = S_mulexp10(result[0],exponent+exp_adjust[0]);
1831 /* now apply the sign */
1833 result[2] = -result[2];
1834 #endif /* USE_PERL_ATOF */
1840 =for apidoc isinfnan
1842 C<Perl_isinfnan()> is a utility function that returns true if the NV
1843 argument is either an infinity or a C<NaN>, false otherwise. To test
1844 in more detail, use C<Perl_isinf()> and C<Perl_isnan()>.
1846 This is also the logical inverse of Perl_isfinite().
1851 Perl_isinfnan(NV nv)
1853 PERL_UNUSED_ARG(nv);
1866 =for apidoc isinfnansv
1868 Checks whether the argument would be either an infinity or C<NaN> when used
1869 as a number, but is careful not to trigger non-numeric or uninitialized
1870 warnings. it assumes the caller has done C<SvGETMAGIC(sv)> already.
1876 Perl_isinfnansv(pTHX_ SV *sv)
1878 PERL_ARGS_ASSERT_ISINFNANSV;
1882 return Perl_isinfnan(SvNVX(sv));
1887 const char *s = SvPV_nomg_const(sv, len);
1888 return cBOOL(grok_infnan(&s, s+len));
1893 /* C99 has truncl, pre-C99 Solaris had aintl. We can use either with
1894 * copysignl to emulate modfl, which is in some platforms missing or
1896 # if defined(HAS_TRUNCL) && defined(HAS_COPYSIGNL)
1898 Perl_my_modfl(long double x, long double *ip)
1901 return (x == *ip ? copysignl(0.0L, x) : x - *ip);
1903 # elif defined(HAS_AINTL) && defined(HAS_COPYSIGNL)
1905 Perl_my_modfl(long double x, long double *ip)
1908 return (x == *ip ? copysignl(0.0L, x) : x - *ip);
1913 /* Similarly, with ilogbl and scalbnl we can emulate frexpl. */
1914 #if ! defined(HAS_FREXPL) && defined(HAS_ILOGBL) && defined(HAS_SCALBNL)
1916 Perl_my_frexpl(long double x, int *e) {
1917 *e = x == 0.0L ? 0 : ilogbl(x) + 1;
1918 return (scalbnl(x, -*e));
1923 =for apidoc Perl_signbit
1925 Return a non-zero integer if the sign bit on an NV is set, and 0 if
1928 If F<Configure> detects this system has a C<signbit()> that will work with
1929 our NVs, then we just use it via the C<#define> in F<perl.h>. Otherwise,
1930 fall back on this implementation. The main use of this function
1931 is catching C<-0.0>.
1933 C<Configure> notes: This function is called C<'Perl_signbit'> instead of a
1934 plain C<'signbit'> because it is easy to imagine a system having a C<signbit()>
1935 function or macro that doesn't happen to work with our particular choice
1936 of NVs. We shouldn't just re-C<#define> C<signbit> as C<Perl_signbit> and expect
1937 the standard system headers to be happy. Also, this is a no-context
1938 function (no C<pTHX_>) because C<Perl_signbit()> is usually re-C<#defined> in
1939 F<perl.h> as a simple macro call to the system's C<signbit()>.
1940 Users should just always call C<Perl_signbit()>.
1944 #if !defined(HAS_SIGNBIT)
1946 Perl_signbit(NV x) {
1947 # ifdef Perl_fp_class_nzero
1948 return Perl_fp_class_nzero(x);
1949 /* Try finding the high byte, and assume it's highest bit
1950 * is the sign. This assumption is probably wrong somewhere. */
1951 # elif defined(USE_LONG_DOUBLE) && LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_LITTLE_ENDIAN
1952 return (((unsigned char *)&x)[9] & 0x80);
1953 # elif defined(NV_LITTLE_ENDIAN)
1954 /* Note that NVSIZE is sizeof(NV), which would make the below be
1955 * wrong if the end bytes are unused, which happens with the x86
1956 * 80-bit long doubles, which is why take care of that above. */
1957 return (((unsigned char *)&x)[NVSIZE - 1] & 0x80);
1958 # elif defined(NV_BIG_ENDIAN)
1959 return (((unsigned char *)&x)[0] & 0x80);
1961 /* This last resort fallback is wrong for the negative zero. */
1962 return (x < 0.0) ? 1 : 0;
1968 * ex: set ts=8 sts=4 sw=4 et: