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"]
20 This file contains all the stuff needed by perl for manipulating numeric
21 values, including such things as replacements for the OS's atof() function
26 #define PERL_IN_NUMERIC_C
32 S_strtod(pTHX_ const char * const s, char ** e)
34 DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
37 STORE_LC_NUMERIC_SET_TO_NEEDED();
41 result = strtoflt128(s, e);
43 # elif defined(HAS_STRTOLD) && defined(HAS_LONG_DOUBLE) \
44 && defined(USE_LONG_DOUBLE)
45 # if defined(__MINGW64_VERSION_MAJOR)
46 /***********************************************
47 We are unable to use strtold because of
48 https://sourceforge.net/p/mingw-w64/bugs/711/
50 https://sourceforge.net/p/mingw-w64/bugs/725/
52 but __mingw_strtold is fine.
53 ***********************************************/
55 result = __mingw_strtold(s, e);
59 result = strtold(s, e);
62 # elif defined(HAS_STRTOD)
64 result = strtod(s, e);
67 # error No strtod() equivalent found
75 #endif /* #ifdef Perl_strtod */
81 This function is equivalent to the libc strtod() function, and is available
82 even on platforms that lack plain strtod(). Its return value is the best
83 available precision depending on platform capabilities and F<Configure>
86 It properly handles the locale radix character, meaning it expects a dot except
87 when called from within the scope of S<C<use locale>>, in which case the radix
88 character should be that specified by the current locale.
90 The synonym Strtod() may be used instead.
97 Perl_my_strtod(const char * const s, char **e)
101 PERL_ARGS_ASSERT_MY_STRTOD;
105 return S_strtod(aTHX_ s, e);
113 end_ptr = my_atof2(s, &result);
131 Perl_cast_ulong(NV f)
134 return f < I32_MIN ? (U32) I32_MIN : (U32)(I32) f;
135 if (f < U32_MAX_P1) {
137 if (f < U32_MAX_P1_HALF)
139 f -= U32_MAX_P1_HALF;
140 return ((U32) f) | (1 + (U32_MAX >> 1));
145 return f > 0 ? U32_MAX : 0 /* NaN */;
152 return f < I32_MIN ? I32_MIN : (I32) f;
153 if (f < U32_MAX_P1) {
155 if (f < U32_MAX_P1_HALF)
157 f -= U32_MAX_P1_HALF;
158 return (I32)(((U32) f) | (1 + (U32_MAX >> 1)));
163 return f > 0 ? (I32)U32_MAX : 0 /* NaN */;
170 return f < IV_MIN ? IV_MIN : (IV) f;
173 /* For future flexibility allowing for sizeof(UV) >= sizeof(IV) */
174 if (f < UV_MAX_P1_HALF)
177 return (IV)(((UV) f) | (1 + (UV_MAX >> 1)));
182 return f > 0 ? (IV)UV_MAX : 0 /* NaN */;
189 return f < IV_MIN ? (UV) IV_MIN : (UV)(IV) f;
192 if (f < UV_MAX_P1_HALF)
195 return ((UV) f) | (1 + (UV_MAX >> 1));
200 return f > 0 ? UV_MAX : 0 /* NaN */;
206 converts a string representing a binary number to numeric form.
208 On entry C<start> and C<*len_p> give the string to scan, C<*flags> gives
209 conversion flags, and C<result> should be C<NULL> or a pointer to an NV. The
210 scan stops at the end of the string, or at just before the first invalid
211 character. Unless C<PERL_SCAN_SILENT_ILLDIGIT> is set in C<*flags>,
212 encountering an invalid character (except NUL) will also trigger a warning. On
213 return C<*len_p> is set to the length of the scanned string, and C<*flags>
216 If the value is <= C<UV_MAX> it is returned as a UV, the output flags are clear,
217 and nothing is written to C<*result>. If the value is > C<UV_MAX>, C<grok_bin>
218 returns C<UV_MAX>, sets C<PERL_SCAN_GREATER_THAN_UV_MAX> in the output flags,
219 and writes an approximation of the correct value into C<*result> (which is an
220 NV; or the approximation is discarded if C<result> is NULL).
222 The binary number may optionally be prefixed with C<"0b"> or C<"b"> unless
223 C<PERL_SCAN_DISALLOW_PREFIX> is set in C<*flags> on entry.
225 If C<PERL_SCAN_ALLOW_UNDERSCORES> is set in C<*flags> then any or all pairs of
226 digits may be separated from each other by a single underscore; also a single
227 leading underscore is accepted.
229 =for apidoc Amnh||PERL_SCAN_ALLOW_UNDERSCORES
230 =for apidoc Amnh||PERL_SCAN_DISALLOW_PREFIX
231 =for apidoc Amnh||PERL_SCAN_GREATER_THAN_UV_MAX
232 =for apidoc Amnh||PERL_SCAN_SILENT_ILLDIGIT
236 Not documented yet because experimental is C<PERL_SCAN_SILENT_NON_PORTABLE
237 which suppresses any message for non-portable numbers that are still valid
242 Perl_grok_bin(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result)
244 PERL_ARGS_ASSERT_GROK_BIN;
246 return grok_bin(start, len_p, flags, result);
252 converts a string representing a hex number to numeric form.
254 On entry C<start> and C<*len_p> give the string to scan, C<*flags> gives
255 conversion flags, and C<result> should be C<NULL> or a pointer to an NV. The
256 scan stops at the end of the string, or at just before the first invalid
257 character. Unless C<PERL_SCAN_SILENT_ILLDIGIT> is set in C<*flags>,
258 encountering an invalid character (except NUL) will also trigger a warning. On
259 return C<*len_p> is set to the length of the scanned string, and C<*flags>
262 If the value is <= C<UV_MAX> it is returned as a UV, the output flags are clear,
263 and nothing is written to C<*result>. If the value is > C<UV_MAX>, C<grok_hex>
264 returns C<UV_MAX>, sets C<PERL_SCAN_GREATER_THAN_UV_MAX> in the output flags,
265 and writes an approximation of the correct value into C<*result> (which is an
266 NV; or the approximation is discarded if C<result> is NULL).
268 The hex number may optionally be prefixed with C<"0x"> or C<"x"> unless
269 C<PERL_SCAN_DISALLOW_PREFIX> is set in C<*flags> on entry.
271 If C<PERL_SCAN_ALLOW_UNDERSCORES> is set in C<*flags> then any or all pairs of
272 digits may be separated from each other by a single underscore; also a single
273 leading underscore is accepted.
277 Not documented yet because experimental is C<PERL_SCAN_SILENT_NON_PORTABLE>
278 which suppresses any message for non-portable numbers, but which are valid
279 on this platform. But, C<*flags> will have the corresponding flag bit set.
283 Perl_grok_hex(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result)
285 PERL_ARGS_ASSERT_GROK_HEX;
287 return grok_hex(start, len_p, flags, result);
293 converts a string representing an octal number to numeric form.
295 On entry C<start> and C<*len_p> give the string to scan, C<*flags> gives
296 conversion flags, and C<result> should be C<NULL> or a pointer to an NV. The
297 scan stops at the end of the string, or at just before the first invalid
298 character. Unless C<PERL_SCAN_SILENT_ILLDIGIT> is set in C<*flags>,
299 encountering an invalid character (except NUL) will also trigger a warning. On
300 return C<*len_p> is set to the length of the scanned string, and C<*flags>
303 If the value is <= C<UV_MAX> it is returned as a UV, the output flags are clear,
304 and nothing is written to C<*result>. If the value is > C<UV_MAX>, C<grok_oct>
305 returns C<UV_MAX>, sets C<PERL_SCAN_GREATER_THAN_UV_MAX> in the output flags,
306 and writes an approximation of the correct value into C<*result> (which is an
307 NV; or the approximation is discarded if C<result> is NULL).
309 If C<PERL_SCAN_ALLOW_UNDERSCORES> is set in C<*flags> then any or all pairs of
310 digits may be separated from each other by a single underscore; also a single
311 leading underscore is accepted.
313 The C<PERL_SCAN_DISALLOW_PREFIX> flag is always treated as being set for
318 Not documented yet because experimental is C<PERL_SCAN_SILENT_NON_PORTABLE>
319 which suppresses any message for non-portable numbers, but which are valid
324 Perl_grok_oct(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result)
326 PERL_ARGS_ASSERT_GROK_OCT;
328 return grok_oct(start, len_p, flags, result);
332 S_output_non_portable(pTHX_ const U8 base)
334 /* Display the proper message for a number in the given input base not
335 * fitting in 32 bits */
336 const char * which = (base == 2)
337 ? "Binary number > 0b11111111111111111111111111111111"
339 ? "Octal number > 037777777777"
340 : "Hexadecimal number > 0xffffffff";
342 PERL_ARGS_ASSERT_OUTPUT_NON_PORTABLE;
344 /* Also there are listings for the other two. That's because, since they
345 * are the first word, it would be hard for a user to find them there
346 * starting with a %s */
347 /* diag_listed_as: Hexadecimal number > 0xffffffff non-portable */
348 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE), "%s non-portable", which);
352 Perl_grok_bin_oct_hex(pTHX_ const char *start,
356 const unsigned shift, /* 1 for binary; 3 for octal;
363 const char *s0 = start;
366 STRLEN bytes_so_far; /* How many real digits have been processed */
369 const PERL_UINT_FAST8_T base = 1 << shift; /* 2, 8, or 16 */
370 const UV max_div= UV_MAX / base; /* Value above which, the next digit
371 processed would overflow */
372 const I32 input_flags = *flags;
373 const bool allow_underscores =
374 cBOOL(input_flags & PERL_SCAN_ALLOW_UNDERSCORES);
375 bool overflowed = FALSE;
377 /* In overflows, this keeps track of how much to multiply the overflowed NV
378 * by as we continue to parse the remaining digits */
381 /* This function unifies the core of grok_bin, grok_oct, and grok_hex. It
382 * is optimized for hex conversion. For example, it uses XDIGIT_VALUE to
383 * find the numeric value of a digit. That requires more instructions than
384 * OCTAL_VALUE would, but gives the same result for the narrowed range of
385 * octal digits; same for binary. If it were ever critical to squeeze more
386 * performance from this, the function could become grok_hex, and a regen
387 * perl script could scan it and write out two edited copies for the other
388 * two functions. That would improve the performance of all three
389 * somewhat. Besides eliminating XDIGIT_VALUE for the other two, extra
390 * parameters are now passed to this to avoid conditionals. Those could
391 * become declared consts, like:
392 * const U8 base = 16;
397 PERL_ARGS_ASSERT_GROK_BIN_OCT_HEX;
399 ASSUME(inRANGE(shift, 1, 4) && shift != 2);
401 /* Clear output flags; unlikely to find a problem that sets them */
404 if (!(input_flags & PERL_SCAN_DISALLOW_PREFIX)) {
406 /* strip off leading b or 0b; x or 0x.
407 for compatibility silently suffer "b" and "0b" as valid binary; "x"
408 and "0x" as valid hex numbers. */
410 if (isALPHA_FOLD_EQ(s0[0], prefix)) {
414 else if (len >= 2 && s0[0] == '0' && (isALPHA_FOLD_EQ(s0[1], prefix))) {
421 s = s0; /* s0 potentially advanced from 'start' */
423 /* Unroll the loop so that the first 8 digits are branchless except for the
424 * switch. A ninth hex one overflows a 32 bit word. */
429 if (UNLIKELY(! generic_isCC_(*s, class_bit))) break;
430 value = (value << shift) | XDIGIT_VALUE(*s);
434 if (UNLIKELY(! generic_isCC_(*s, class_bit))) break;
435 value = (value << shift) | XDIGIT_VALUE(*s);
439 if (UNLIKELY(! generic_isCC_(*s, class_bit))) break;
440 value = (value << shift) | XDIGIT_VALUE(*s);
444 if (UNLIKELY(! generic_isCC_(*s, class_bit))) break;
445 value = (value << shift) | XDIGIT_VALUE(*s);
449 if (UNLIKELY(! generic_isCC_(*s, class_bit))) break;
450 value = (value << shift) | XDIGIT_VALUE(*s);
454 if (UNLIKELY(! generic_isCC_(*s, class_bit))) break;
455 value = (value << shift) | XDIGIT_VALUE(*s);
459 if (UNLIKELY(! generic_isCC_(*s, class_bit))) break;
460 value = (value << shift) | XDIGIT_VALUE(*s);
464 if (UNLIKELY(! generic_isCC_(*s, class_bit))) break;
465 value = (value << shift) | XDIGIT_VALUE(*s);
467 if (LIKELY(len <= 8)) {
475 bytes_so_far = s - s0;
476 factor = shift << bytes_so_far;
480 if (generic_isCC_(*s, class_bit)) {
481 /* Write it in this wonky order with a goto to attempt to get the
482 compiler to make the common case integer-only loop pretty tight.
483 With gcc seems to be much straighter code than old scan_hex.
484 (khw suspects that adding a LIKELY() just above would do the
487 if (LIKELY(value <= max_div)) {
488 value = (value << shift) | XDIGIT_VALUE(*s);
489 /* Note XDIGIT_VALUE() is branchless, works on binary
490 * and octal as well, so can be used here, without
491 * slowing those down */
492 factor *= 1 << shift;
496 /* Bah. We are about to overflow. Instead, add the unoverflowed
497 * value to an NV that contains an approximation to the correct
498 * value. Each time through the loop we have increased 'factor' so
499 * that it gives how much the current approximation needs to
500 * effectively be shifted to make room for this new value */
502 value_nv += (NV) value;
504 /* Then we keep accumulating digits, until all are parsed. We
505 * start over using the current input value. This will be added to
506 * 'value_nv' eventually, either when all digits are gone, or we
507 * have overflowed this fresh start. */
508 value = XDIGIT_VALUE(*s);
513 if ( ! (input_flags & PERL_SCAN_SILENT_OVERFLOW)
514 && ckWARN_d(WARN_OVERFLOW))
516 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
517 "Integer overflow in %s number",
518 (base == 16) ? "hexadecimal"
530 && generic_isCC_(s[1], class_bit)
532 /* Don't allow a leading underscore if the only-medial bit is
535 || UNLIKELY((input_flags & PERL_SCAN_ALLOW_MEDIAL_UNDERSCORES)
536 != PERL_SCAN_ALLOW_MEDIAL_UNDERSCORES)))
544 if ( ! (input_flags & PERL_SCAN_SILENT_ILLDIGIT)
545 && ckWARN(WARN_DIGIT))
548 Perl_warner(aTHX_ packWARN(WARN_DIGIT),
549 "Illegal %s digit '%c' ignored",
555 else if (isDIGIT(*s)) { /* octal base */
557 /* Allow \octal to work the DWIM way (that is, stop
558 * scanning as soon as non-octal characters are seen,
559 * complain only if someone seems to want to use the digits
560 * eight and nine. Since we know it is not octal, then if
561 * isDIGIT, must be an 8 or 9). */
562 Perl_warner(aTHX_ packWARN(WARN_DIGIT),
563 "Illegal octal digit '%c' ignored", *s);
567 if (input_flags & PERL_SCAN_NOTIFY_ILLDIGIT) {
568 *flags |= PERL_SCAN_NOTIFY_ILLDIGIT;
577 if (LIKELY(! overflowed)) {
579 if ( UNLIKELY(value > 0xffffffff)
580 && ! (input_flags & PERL_SCAN_SILENT_NON_PORTABLE))
582 output_non_portable(base);
583 *flags |= PERL_SCAN_SILENT_NON_PORTABLE;
589 /* Overflowed: Calculate the final overflow approximation */
591 value_nv += (NV) value;
593 output_non_portable(base);
595 *flags |= PERL_SCAN_GREATER_THAN_UV_MAX
596 | PERL_SCAN_SILENT_NON_PORTABLE;
605 For backwards compatibility. Use C<grok_bin> instead.
609 For backwards compatibility. Use C<grok_hex> instead.
613 For backwards compatibility. Use C<grok_oct> instead.
619 Perl_scan_bin(pTHX_ const char *start, STRLEN len, STRLEN *retlen)
622 I32 flags = *retlen ? PERL_SCAN_ALLOW_UNDERSCORES : 0;
623 const UV ruv = grok_bin (start, &len, &flags, &rnv);
625 PERL_ARGS_ASSERT_SCAN_BIN;
628 return (flags & PERL_SCAN_GREATER_THAN_UV_MAX) ? rnv : (NV)ruv;
632 Perl_scan_oct(pTHX_ const char *start, STRLEN len, STRLEN *retlen)
635 I32 flags = *retlen ? PERL_SCAN_ALLOW_UNDERSCORES : 0;
636 const UV ruv = grok_oct (start, &len, &flags, &rnv);
638 PERL_ARGS_ASSERT_SCAN_OCT;
641 return (flags & PERL_SCAN_GREATER_THAN_UV_MAX) ? rnv : (NV)ruv;
645 Perl_scan_hex(pTHX_ const char *start, STRLEN len, STRLEN *retlen)
648 I32 flags = *retlen ? PERL_SCAN_ALLOW_UNDERSCORES : 0;
649 const UV ruv = grok_hex (start, &len, &flags, &rnv);
651 PERL_ARGS_ASSERT_SCAN_HEX;
654 return (flags & PERL_SCAN_GREATER_THAN_UV_MAX) ? rnv : (NV)ruv;
658 =for apidoc grok_numeric_radix
660 Scan and skip for a numeric decimal separator (radix).
665 Perl_grok_numeric_radix(pTHX_ const char **sp, const char *send)
667 PERL_ARGS_ASSERT_GROK_NUMERIC_RADIX;
669 #ifdef USE_LOCALE_NUMERIC
671 if (IN_LC(LC_NUMERIC)) {
674 bool matches_radix = FALSE;
675 DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
677 STORE_LC_NUMERIC_FORCE_TO_UNDERLYING();
679 radix = SvPV(PL_numeric_radix_sv, len);
680 radix = savepvn(radix, len);
682 RESTORE_LC_NUMERIC();
684 if (*sp + len <= send) {
685 matches_radix = memEQ(*sp, radix, len);
698 /* always try "." if numeric radix didn't match because
699 * we may have data from different locales mixed */
700 if (*sp < send && **sp == '.') {
709 =for apidoc grok_infnan
711 Helper for C<grok_number()>, accepts various ways of spelling "infinity"
712 or "not a number", and returns one of the following flag combinations:
716 IS_NUMBER_INFINITY | IS_NUMBER_NEG
717 IS_NUMBER_NAN | IS_NUMBER_NEG
720 possibly |-ed with C<IS_NUMBER_TRAILING>.
722 If an infinity or a not-a-number is recognized, C<*sp> will point to
723 one byte past the end of the recognized string. If the recognition fails,
724 zero is returned, and C<*sp> will not move.
726 =for apidoc Amnh|bool|IS_NUMBER_GREATER_THAN_UV_MAX
727 =for apidoc Amnh|bool|IS_NUMBER_INFINITY
728 =for apidoc Amnh|bool|IS_NUMBER_IN_UV
729 =for apidoc Amnh|bool|IS_NUMBER_NAN
730 =for apidoc Amnh|bool|IS_NUMBER_NEG
731 =for apidoc Amnh|bool|IS_NUMBER_NOT_INT
737 Perl_grok_infnan(pTHX_ const char** sp, const char* send)
741 #if defined(NV_INF) || defined(NV_NAN)
742 bool odh = FALSE; /* one-dot-hash: 1.#INF */
744 PERL_ARGS_ASSERT_GROK_INFNAN;
747 s++; if (s == send) return 0;
749 else if (*s == '-') {
750 flags |= IS_NUMBER_NEG; /* Yes, -NaN happens. Incorrect but happens. */
751 s++; if (s == send) return 0;
755 /* Visual C: 1.#SNAN, -1.#QNAN, 1#INF, 1.#IND (maybe also 1.#NAN)
756 * Let's keep the dot optional. */
757 s++; if (s == send) return 0;
759 s++; if (s == send) return 0;
762 s++; if (s == send) return 0;
768 if (isALPHA_FOLD_EQ(*s, 'I')) {
769 /* INF or IND (1.#IND is "indeterminate", a certain type of NAN) */
771 s++; if (s == send || isALPHA_FOLD_NE(*s, 'N')) return 0;
772 s++; if (s == send) return 0;
773 if (isALPHA_FOLD_EQ(*s, 'F')) {
774 flags |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT;
776 if (s < send && (isALPHA_FOLD_EQ(*s, 'I'))) {
777 int trail = flags | IS_NUMBER_TRAILING;
778 s++; if (s == send || isALPHA_FOLD_NE(*s, 'N')) return trail;
779 s++; if (s == send || isALPHA_FOLD_NE(*s, 'I')) return trail;
780 s++; if (s == send || isALPHA_FOLD_NE(*s, 'T')) return trail;
781 s++; if (s == send || isALPHA_FOLD_NE(*s, 'Y')) return trail;
784 while (s < send && *s == '0') { /* 1.#INF00 */
790 else if (isALPHA_FOLD_EQ(*s, 'D') && odh) { /* 1.#IND */
792 flags |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT;
793 while (s < send && *s == '0') { /* 1.#IND00 */
801 /* Maybe NAN of some sort */
803 if (isALPHA_FOLD_EQ(*s, 'S') || isALPHA_FOLD_EQ(*s, 'Q')) {
805 /* XXX do something with the snan/qnan difference */
806 s++; if (s == send) return 0;
809 if (isALPHA_FOLD_EQ(*s, 'N')) {
810 s++; if (s == send || isALPHA_FOLD_NE(*s, 'A')) return 0;
811 s++; if (s == send || isALPHA_FOLD_NE(*s, 'N')) return 0;
812 flags |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT;
819 /* NaN can be followed by various stuff (NaNQ, NaNS), but
820 * there are also multiple different NaN values, and some
821 * implementations output the "payload" values,
822 * e.g. NaN123, NAN(abc), while some legacy implementations
823 * have weird stuff like NaN%. */
824 if (isALPHA_FOLD_EQ(*s, 'q') ||
825 isALPHA_FOLD_EQ(*s, 's')) {
826 /* "nanq" or "nans" are ok, though generating
827 * these portably is tricky. */
834 /* C99 style "nan(123)" or Perlish equivalent "nan($uv)". */
836 int trail = flags | IS_NUMBER_TRAILING;
838 if (s == send) { return trail; }
840 while (t < send && *t && *t != ')') {
843 if (t == send) { return trail; }
847 if (s[0] == '0' && s + 2 < t &&
848 isALPHA_FOLD_EQ(s[1], 'x') &&
851 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
852 nanval = grok_hex(s, &len, &flags, NULL);
853 if ((flags & PERL_SCAN_GREATER_THAN_UV_MAX)) {
856 nantype = IS_NUMBER_IN_UV;
859 } else if (s[0] == '0' && s + 2 < t &&
860 isALPHA_FOLD_EQ(s[1], 'b') &&
861 (s[2] == '0' || s[2] == '1')) {
863 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
864 nanval = grok_bin(s, &len, &flags, NULL);
865 if ((flags & PERL_SCAN_GREATER_THAN_UV_MAX)) {
868 nantype = IS_NUMBER_IN_UV;
874 grok_number_flags(s, t - s, &nanval,
876 PERL_SCAN_ALLOW_UNDERSCORES);
877 /* Unfortunately grok_number_flags() doesn't
878 * tell how far we got and the ')' will always
879 * be "trailing", so we need to double-check
880 * whether we had something dubious. */
881 for (u = s; u < t; u++) {
888 /* XXX Doesn't do octal: nan("0123").
889 * Probably not a big loss. */
891 /* XXX the nanval is currently unused, that is,
892 * not inserted as the NaN payload of the NV.
893 * But the above code already parses the C99
894 * nan(...) format. See below, and see also
895 * the nan() in POSIX.xs.
897 * Certain configuration combinations where
898 * NVSIZE is greater than UVSIZE mean that
899 * a single UV cannot contain all the possible
900 * NaN payload bits. There would need to be
901 * some more generic syntax than "nan($uv)".
903 * Issues to keep in mind:
905 * (1) In most common cases there would
906 * not be an integral number of bytes that
907 * could be set, only a certain number of bits.
908 * For example for the common case of
909 * NVSIZE == UVSIZE == 8 there is room for 52
910 * bits in the payload, but the most significant
911 * bit is commonly reserved for the
912 * signaling/quiet bit, leaving 51 bits.
913 * Furthermore, the C99 nan() is supposed
914 * to generate quiet NaNs, so it is doubtful
915 * whether it should be able to generate
916 * signaling NaNs. For the x86 80-bit doubles
917 * (if building a long double Perl) there would
918 * be 62 bits (s/q bit being the 63rd).
920 * (2) Endianness of the payload bits. If the
921 * payload is specified as an UV, the low-order
922 * bits of the UV are naturally little-endianed
923 * (rightmost) bits of the payload. The endianness
924 * of UVs and NVs can be different. */
926 if ((nantype & IS_NUMBER_NOT_INT) ||
927 !(nantype && IS_NUMBER_IN_UV)) {
928 /* treat "NaN(invalid)" the same as "NaNgarbage" */
932 /* allow whitespace between valid payload and ')' */
933 while (s < t && isSPACE(*s))
935 /* but on anything else treat the whole '(...)' chunk
936 * as trailing garbage */
943 /* Looked like nan(...), but no close paren. */
947 /* Note that we here implicitly accept (parse as
948 * "nan", but with warnings) also any other weird
949 * trailing stuff for "nan". In the above we just
950 * check that if we got the C99-style "nan(...)",
951 * the "..." looks sane.
952 * If in future we accept more ways of specifying
953 * the nan payload, the accepting would happen around
961 NOT_REACHED; /* NOTREACHED */
963 /* We parsed something valid, s points after it, flags describes it */
965 while (s < send && isSPACE(*s))
968 return flags | (s < send ? IS_NUMBER_TRAILING : 0);
971 PERL_UNUSED_ARG(send);
974 #endif /* #if defined(NV_INF) || defined(NV_NAN) */
978 =for apidoc grok_number_flags
980 Recognise (or not) a number. The type of the number is returned
981 (0 if unrecognised), otherwise it is a bit-ORed combination of
982 C<IS_NUMBER_IN_UV>, C<IS_NUMBER_GREATER_THAN_UV_MAX>, C<IS_NUMBER_NOT_INT>,
983 C<IS_NUMBER_NEG>, C<IS_NUMBER_INFINITY>, C<IS_NUMBER_NAN> (defined in perl.h).
985 If the value of the number can fit in a UV, it is returned in C<*valuep>.
986 C<IS_NUMBER_IN_UV> will be set to indicate that C<*valuep> is valid, C<IS_NUMBER_IN_UV>
987 will never be set unless C<*valuep> is valid, but C<*valuep> may have been assigned
988 to during processing even though C<IS_NUMBER_IN_UV> is not set on return.
989 If C<valuep> is C<NULL>, C<IS_NUMBER_IN_UV> will be set for the same cases as when
990 C<valuep> is non-C<NULL>, but no actual assignment (or SEGV) will occur.
992 C<IS_NUMBER_NOT_INT> will be set with C<IS_NUMBER_IN_UV> if trailing decimals were
993 seen (in which case C<*valuep> gives the true value truncated to an integer), and
994 C<IS_NUMBER_NEG> if the number is negative (in which case C<*valuep> holds the
995 absolute value). C<IS_NUMBER_IN_UV> is not set if C<e> notation was used or the
996 number is larger than a UV.
998 C<flags> allows only C<PERL_SCAN_TRAILING>, which allows for trailing
999 non-numeric text on an otherwise successful I<grok>, setting
1000 C<IS_NUMBER_TRAILING> on the result.
1002 =for apidoc Amnh||PERL_SCAN_TRAILING
1004 =for apidoc grok_number
1006 Identical to C<grok_number_flags()> with C<flags> set to zero.
1011 Perl_grok_number(pTHX_ const char *pv, STRLEN len, UV *valuep)
1013 PERL_ARGS_ASSERT_GROK_NUMBER;
1015 return grok_number_flags(pv, len, valuep, 0);
1018 static const UV uv_max_div_10 = UV_MAX / 10;
1019 static const U8 uv_max_mod_10 = UV_MAX % 10;
1022 Perl_grok_number_flags(pTHX_ const char *pv, STRLEN len, UV *valuep, U32 flags)
1025 const char * const send = pv + len;
1029 PERL_ARGS_ASSERT_GROK_NUMBER_FLAGS;
1031 if (UNLIKELY(isSPACE(*s))) {
1034 if (LIKELY(! isSPACE(*s))) goto non_space;
1041 /* See if signed. This assumes it is more likely to be unsigned, so
1042 * penalizes signed by an extra conditional; rewarding unsigned by one fewer
1043 * (because we detect '+' and '-' with a single test and then add a
1044 * conditional to determine which) */
1045 if (UNLIKELY((*s & ~('+' ^ '-')) == ('+' & '-') )) {
1047 /* Here, on ASCII platforms, *s is one of: 0x29 = ')', 2B = '+', 2D = '-',
1048 * 2F = '/'. That is, it is either a sign, or a character that doesn't
1049 * belong in a number at all (unless it's a radix character in a weird
1050 * locale). Given this, it's far more likely to be a minus than the
1051 * others. (On EBCDIC it is one of 42, 44, 46, 48, 4A, 4C, 4E, (not 40
1052 * because can't be a space) 60, 62, 64, 66, 68, 6A, 6C, 6E. Again,
1053 * only potentially a weird radix character, or 4E='+', or 60='-') */
1054 if (LIKELY(*s == '-')) {
1056 numtype = IS_NUMBER_NEG;
1058 else if (LIKELY(*s == '+'))
1060 else /* Can't just return failure here, as it could be a weird radix
1064 if (UNLIKELY(s == send))
1069 /* The first digit (after optional sign): note that might
1070 * also point to "infinity" or "nan", or "1.#INF". */
1073 /* next must be digit or the radix separator or beginning of infinity/nan */
1074 if (LIKELY(isDIGIT(*s))) {
1075 /* UVs are at least 32 bits, so the first 9 decimal digits cannot
1077 UV value = *s - '0'; /* Process this first (perhaps only) digit */
1083 default: /* 8 or more remaining characters */
1085 if (UNLIKELY(! inRANGE(digit, 0, 9))) break;
1086 value = value * 10 + digit;
1091 if (UNLIKELY(! inRANGE(digit, 0, 9))) break;
1092 value = value * 10 + digit;
1097 if (UNLIKELY(! inRANGE(digit, 0, 9))) break;
1098 value = value * 10 + digit;
1103 if (UNLIKELY(! inRANGE(digit, 0, 9))) break;
1104 value = value * 10 + digit;
1109 if (UNLIKELY(! inRANGE(digit, 0, 9))) break;
1110 value = value * 10 + digit;
1115 if (UNLIKELY(! inRANGE(digit, 0, 9))) break;
1116 value = value * 10 + digit;
1121 if (UNLIKELY(! inRANGE(digit, 0, 9))) break;
1122 value = value * 10 + digit;
1127 if (UNLIKELY(! inRANGE(digit, 0, 9))) break;
1128 value = value * 10 + digit;
1131 case 0: /* This case means the string consists of just the one
1132 digit we already have processed */
1134 /* If we got here by falling through other than the default: case, we
1135 * have processed the whole string, and know it consists entirely of
1136 * digits, and can't have overflowed. */
1140 return numtype|IS_NUMBER_IN_UV;
1143 /* Here, there are extra characters beyond the first 9 digits. Use a
1144 * loop to accumulate any remaining digits, until we get a non-digit or
1145 * would overflow. Note that leading zeros could cause us to get here
1146 * without being close to overflowing.
1148 * (The conditional 's >= send' above could be eliminated by making the
1149 * default: in the switch to instead be 'case 8:', and process longer
1150 * strings separately by using the loop below. This would penalize
1151 * these inputs by the extra instructions needed for looping. That
1152 * could be eliminated by copying the unwound code from above to handle
1153 * the firt 9 digits of these. khw didn't think this saving of a
1154 * single conditional was worth it.) */
1157 if (! inRANGE(digit, 0, 9)) goto mantissa_done;
1158 if ( value < uv_max_div_10
1159 || ( value == uv_max_div_10
1160 && digit <= uv_max_mod_10))
1162 value = value * 10 + digit;
1165 else { /* value would overflow. skip the remaining digits, don't
1166 worry about setting *valuep. */
1169 } while (s < send && isDIGIT(*s));
1171 IS_NUMBER_GREATER_THAN_UV_MAX;
1175 } /* End switch on input length */
1178 numtype |= IS_NUMBER_IN_UV;
1183 if (GROK_NUMERIC_RADIX(&s, send)) {
1184 numtype |= IS_NUMBER_NOT_INT;
1185 while (s < send && isDIGIT(*s)) /* optional digits after the radix */
1188 } /* End of *s is a digit */
1189 else if (GROK_NUMERIC_RADIX(&s, send)) {
1190 numtype |= IS_NUMBER_NOT_INT | IS_NUMBER_IN_UV; /* valuep assigned below */
1191 /* no digits before the radix means we need digits after it */
1192 if (s < send && isDIGIT(*s)) {
1195 } while (s < send && isDIGIT(*s));
1197 /* integer approximation is valid - it's 0. */
1205 if (LIKELY(s > d) && s < send) {
1206 /* we can have an optional exponent part */
1207 if (UNLIKELY(isALPHA_FOLD_EQ(*s, 'e'))) {
1209 if (s < send && (*s == '-' || *s == '+'))
1211 if (s < send && isDIGIT(*s)) {
1214 } while (s < send && isDIGIT(*s));
1216 else if (flags & PERL_SCAN_TRAILING)
1217 return numtype | IS_NUMBER_TRAILING;
1221 /* The only flag we keep is sign. Blow away any "it's UV" */
1222 numtype &= IS_NUMBER_NEG;
1223 numtype |= IS_NUMBER_NOT_INT;
1228 if (LIKELY(! isSPACE(*s))) goto end_space;
1235 if (UNLIKELY(memEQs(pv, len, "0 but true"))) {
1238 return IS_NUMBER_IN_UV;
1241 /* We could be e.g. at "Inf" or "NaN", or at the "#" of "1.#INF". */
1242 if ((s + 2 < send) && UNLIKELY(memCHRs("inqs#", toFOLD(*s)))) {
1243 /* Really detect inf/nan. Start at d, not s, since the above
1244 * code might have already consumed the "1." or "1". */
1245 const int infnan = Perl_grok_infnan(aTHX_ &d, send);
1247 if ((infnan & IS_NUMBER_TRAILING) && !(flags & PERL_SCAN_TRAILING)) {
1250 if ((infnan & IS_NUMBER_INFINITY)) {
1251 return (numtype | infnan); /* Keep sign for infinity. */
1253 else if ((infnan & IS_NUMBER_NAN)) {
1254 return (numtype | infnan) & ~IS_NUMBER_NEG; /* Clear sign for nan. */
1257 else if (flags & PERL_SCAN_TRAILING) {
1258 return numtype | IS_NUMBER_TRAILING;
1265 =for apidoc grok_atoUV
1267 parse a string, looking for a decimal unsigned integer.
1269 On entry, C<pv> points to the beginning of the string;
1270 C<valptr> points to a UV that will receive the converted value, if found;
1271 C<endptr> is either NULL or points to a variable that points to one byte
1272 beyond the point in C<pv> that this routine should examine.
1273 If C<endptr> is NULL, C<pv> is assumed to be NUL-terminated.
1275 Returns FALSE if C<pv> doesn't represent a valid unsigned integer value (with
1276 no leading zeros). Otherwise it returns TRUE, and sets C<*valptr> to that
1279 If you constrain the portion of C<pv> that is looked at by this function (by
1280 passing a non-NULL C<endptr>), and if the intial bytes of that portion form a
1281 valid value, it will return TRUE, setting C<*endptr> to the byte following the
1282 final digit of the value. But if there is no constraint at what's looked at,
1283 all of C<pv> must be valid in order for TRUE to be returned. C<*endptr> is
1284 unchanged from its value on input if FALSE is 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)
1473 L<C<atof>(3)>, but properly works with Perl locale handling, accepting a dot
1474 radix character always, but also the current locale's radix character if and
1475 only if called from within the lexical scope of a Perl C<use locale> statement.
1477 N.B. C<s> must be NUL terminated.
1484 PERL_ARGS_ASSERT_MY_ATOF;
1486 #if ! defined(USE_LOCALE_NUMERIC)
1493 DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
1494 STORE_LC_NUMERIC_SET_TO_NEEDED();
1495 if (! (PL_numeric_radix_sv && IN_LC(LC_NUMERIC))) {
1500 /* Look through the string for the first thing that looks like a
1501 * decimal point: either the value in the current locale or the
1502 * standard fallback of '.'. The one which appears earliest in the
1503 * input string is the one that we should have atof look for. Note
1504 * that we have to determine this beforehand because on some
1505 * systems, Perl_atof2 is just a wrapper around the system's atof.
1507 const char * const standard_pos = strchr(s, '.');
1508 const char * const local_pos
1509 = strstr(s, SvPV_nolen(PL_numeric_radix_sv));
1510 const bool use_standard_radix
1511 = standard_pos && (!local_pos || standard_pos < local_pos);
1513 if (use_standard_radix) {
1514 SET_NUMERIC_STANDARD();
1515 LOCK_LC_NUMERIC_STANDARD();
1520 if (use_standard_radix) {
1521 UNLOCK_LC_NUMERIC_STANDARD();
1522 SET_NUMERIC_UNDERLYING();
1525 RESTORE_LC_NUMERIC();
1533 #if defined(NV_INF) || defined(NV_NAN)
1536 S_my_atof_infnan(pTHX_ const char* s, bool negative, const char* send, NV* value)
1538 const char *p0 = negative ? s - 1 : s;
1540 const int infnan = grok_infnan(&p, send);
1541 /* We act like PERL_SCAN_TRAILING here to permit trailing garbage,
1542 * it is not clear if that is desirable.
1544 if (infnan && p != p0) {
1545 /* If we can generate inf/nan directly, let's do so. */
1547 if ((infnan & IS_NUMBER_INFINITY)) {
1548 *value = (infnan & IS_NUMBER_NEG) ? -NV_INF: NV_INF;
1553 if ((infnan & IS_NUMBER_NAN)) {
1559 /* If still here, we didn't have either NV_INF or NV_NAN,
1560 * and can try falling back to native strtod/strtold.
1562 * The native interface might not recognize all the possible
1563 * inf/nan strings Perl recognizes. What we can try
1564 * is to try faking the input. We will try inf/-inf/nan
1565 * as the most promising/portable input. */
1567 const char* fake = "silence compiler warning";
1571 if ((infnan & IS_NUMBER_INFINITY)) {
1572 fake = ((infnan & IS_NUMBER_NEG)) ? "-inf" : "inf";
1576 if ((infnan & IS_NUMBER_NAN)) {
1580 assert(strNE(fake, "silence compiler warning"));
1581 nv = S_strtod(aTHX_ fake, &endp);
1584 if ((infnan & IS_NUMBER_INFINITY)) {
1589 /* last resort, may generate SIGFPE */
1590 *value = Perl_exp((NV)1e9);
1591 if ((infnan & IS_NUMBER_NEG))
1594 return (char*)p; /* p, not endp */
1598 if ((infnan & IS_NUMBER_NAN)) {
1603 /* last resort, may generate SIGFPE */
1604 *value = Perl_log((NV)-1.0);
1606 return (char*)p; /* p, not endp */
1611 #endif /* #ifdef Perl_strtod */
1616 #endif /* if defined(NV_INF) || defined(NV_NAN) */
1619 Perl_my_atof2(pTHX_ const char* orig, NV* value)
1621 PERL_ARGS_ASSERT_MY_ATOF2;
1622 return my_atof3(orig, value, 0);
1626 Perl_my_atof3(pTHX_ const char* orig, NV* value, const STRLEN len)
1628 const char* s = orig;
1629 NV result[3] = {0.0, 0.0, 0.0};
1630 #if defined(USE_PERL_ATOF) || defined(Perl_strtod)
1631 const char* send = s + ((len != 0)
1633 : strlen(orig)); /* one past the last */
1635 #if defined(USE_PERL_ATOF) && !defined(Perl_strtod)
1637 UV accumulator[2] = {0,0}; /* before/after dp */
1638 bool seen_digit = 0;
1639 I32 exp_adjust[2] = {0,0};
1640 I32 exp_acc[2] = {-1, -1};
1641 /* the current exponent adjust for the accumulators */
1646 I32 sig_digits = 0; /* noof significant digits seen so far */
1649 #if defined(USE_PERL_ATOF) || defined(Perl_strtod)
1650 PERL_ARGS_ASSERT_MY_ATOF3;
1652 /* leading whitespace */
1653 while (s < send && isSPACE(*s))
1656 # if defined(NV_INF) || defined(NV_NAN)
1659 if ((endp = S_my_atof_infnan(aTHX_ s, FALSE, send, value)))
1667 # if !defined(Perl_strtod)
1681 /* strtold() accepts 0x-prefixed hex and in POSIX implementations,
1682 0b-prefixed binary numbers, which is backward incompatible
1684 if ((len == 0 || len - (s-orig) >= 2) && *s == '0' &&
1685 (isALPHA_FOLD_EQ(s[1], 'x') || isALPHA_FOLD_EQ(s[1], 'b'))) {
1690 /* We do not want strtod to parse whitespace after the sign, since
1691 * that would give backward-incompatible results. So we rewind and
1692 * let strtod handle the whitespace and sign character itself. */
1695 /* If the length is passed in, the input string isn't NUL-terminated,
1696 * and in it turns out the function below assumes it is; therefore we
1697 * create a copy and NUL-terminate that */
1699 Newx(copy, len + 1, char);
1700 Copy(orig, copy, len, char);
1705 result[2] = S_strtod(aTHX_ s, &endp);
1707 /* If we created a copy, 'endp' is in terms of that. Convert back to
1710 s = (s - copy) + (char *) orig;
1711 endp = (endp - copy) + (char *) orig;
1716 /* Note that negation is handled by strtod. */
1722 #elif defined(USE_PERL_ATOF)
1724 /* There is no point in processing more significant digits
1725 * than the NV can hold. Note that NV_DIG is a lower-bound value,
1726 * while we need an upper-bound value. We add 2 to account for this;
1727 * since it will have been conservative on both the first and last digit.
1728 * For example a 32-bit mantissa with an exponent of 4 would have
1729 * exact values in the set
1737 * where for the purposes of calculating NV_DIG we would have to discount
1738 * both the first and last digit, since neither can hold all values from
1739 * 0..9; but for calculating the value we must examine those two digits.
1741 # ifdef MAX_SIG_DIG_PLUS
1742 /* It is not necessarily the case that adding 2 to NV_DIG gets all the
1743 possible digits in a NV, especially if NVs are not IEEE compliant
1744 (e.g., long doubles on IRIX) - Allen <allens@cpan.org> */
1745 # define MAX_SIG_DIGITS (NV_DIG+MAX_SIG_DIG_PLUS)
1747 # define MAX_SIG_DIGITS (NV_DIG+2)
1750 /* the max number we can accumulate in a UV, and still safely do 10*N+9 */
1751 # define MAX_ACCUMULATE ( (UV) ((UV_MAX - 9)/10))
1753 /* we accumulate digits into an integer; when this becomes too
1754 * large, we add the total to NV and start again */
1764 /* don't start counting until we see the first significant
1765 * digit, eg the 5 in 0.00005... */
1766 if (!sig_digits && digit == 0)
1769 if (++sig_digits > MAX_SIG_DIGITS) {
1770 /* limits of precision reached */
1772 ++accumulator[seen_dp];
1773 } else if (digit == 5) {
1774 if (old_digit % 2) { /* round to even - Allen */
1775 ++accumulator[seen_dp];
1783 /* skip remaining digits */
1784 while (s < send && isDIGIT(*s)) {
1790 /* warn of loss of precision? */
1793 if (accumulator[seen_dp] > MAX_ACCUMULATE) {
1794 /* add accumulator to result and start again */
1795 result[seen_dp] = S_mulexp10(result[seen_dp],
1797 + (NV)accumulator[seen_dp];
1798 accumulator[seen_dp] = 0;
1799 exp_acc[seen_dp] = 0;
1801 accumulator[seen_dp] = accumulator[seen_dp] * 10 + digit;
1805 else if (!seen_dp && GROK_NUMERIC_RADIX(&s, send)) {
1807 if (sig_digits > MAX_SIG_DIGITS) {
1808 while (s < send && isDIGIT(*s)) {
1819 result[0] = S_mulexp10(result[0], exp_acc[0]) + (NV)accumulator[0];
1821 result[1] = S_mulexp10(result[1], exp_acc[1]) + (NV)accumulator[1];
1824 if (s < send && seen_digit && (isALPHA_FOLD_EQ(*s, 'e'))) {
1825 bool expnegative = 0;
1835 while (s < send && isDIGIT(*s))
1836 exponent = exponent * 10 + (*s++ - '0');
1838 exponent = -exponent;
1841 /* now apply the exponent */
1844 result[2] = S_mulexp10(result[0],exponent+exp_adjust[0])
1845 + S_mulexp10(result[1],exponent-exp_adjust[1]);
1847 result[2] = S_mulexp10(result[0],exponent+exp_adjust[0]);
1850 /* now apply the sign */
1852 result[2] = -result[2];
1855 #else /* USE_PERL_ATOF */
1856 /* If you see this error you both don't have strtod (or configured -Ud_strtod or
1857 or it's long double/quadmath equivalent) and disabled USE_PERL_ATOF, thus
1858 removing any way for perl to convert strings to floating point numbers.
1860 # error No mechanism to convert strings to numbers available
1865 =for apidoc isinfnan
1867 C<Perl_isinfnan()> is a utility function that returns true if the NV
1868 argument is either an infinity or a C<NaN>, false otherwise. To test
1869 in more detail, use C<Perl_isinf()> and C<Perl_isnan()>.
1871 This is also the logical inverse of Perl_isfinite().
1876 Perl_isinfnan(NV nv)
1878 PERL_UNUSED_ARG(nv);
1891 =for apidoc isinfnansv
1893 Checks whether the argument would be either an infinity or C<NaN> when used
1894 as a number, but is careful not to trigger non-numeric or uninitialized
1895 warnings. it assumes the caller has done C<SvGETMAGIC(sv)> already.
1897 Note that this always accepts trailing garbage (similar to C<grok_number_flags>
1898 with C<PERL_SCAN_TRAILING>), so C<"inferior"> and C<"NAND gates"> will
1905 Perl_isinfnansv(pTHX_ SV *sv)
1907 PERL_ARGS_ASSERT_ISINFNANSV;
1911 return Perl_isinfnan(SvNVX(sv));
1916 const char *s = SvPV_nomg_const(sv, len);
1917 return cBOOL(grok_infnan(&s, s+len));
1922 /* C99 has truncl, pre-C99 Solaris had aintl. We can use either with
1923 * copysignl to emulate modfl, which is in some platforms missing or
1925 # if defined(HAS_TRUNCL) && defined(HAS_COPYSIGNL)
1927 Perl_my_modfl(long double x, long double *ip)
1930 return (x == *ip ? copysignl(0.0L, x) : x - *ip);
1932 # elif defined(HAS_AINTL) && defined(HAS_COPYSIGNL)
1934 Perl_my_modfl(long double x, long double *ip)
1937 return (x == *ip ? copysignl(0.0L, x) : x - *ip);
1942 /* Similarly, with ilogbl and scalbnl we can emulate frexpl. */
1943 #if ! defined(HAS_FREXPL) && defined(HAS_ILOGBL) && defined(HAS_SCALBNL)
1945 Perl_my_frexpl(long double x, int *e) {
1946 *e = x == 0.0L ? 0 : ilogbl(x) + 1;
1947 return (scalbnl(x, -*e));
1952 =for apidoc Perl_signbit
1954 Return a non-zero integer if the sign bit on an NV is set, and 0 if
1957 If F<Configure> detects this system has a C<signbit()> that will work with
1958 our NVs, then we just use it via the C<#define> in F<perl.h>. Otherwise,
1959 fall back on this implementation. The main use of this function
1960 is catching C<-0.0>.
1962 C<Configure> notes: This function is called C<'Perl_signbit'> instead of a
1963 plain C<'signbit'> because it is easy to imagine a system having a C<signbit()>
1964 function or macro that doesn't happen to work with our particular choice
1965 of NVs. We shouldn't just re-C<#define> C<signbit> as C<Perl_signbit> and expect
1966 the standard system headers to be happy. Also, this is a no-context
1967 function (no C<pTHX_>) because C<Perl_signbit()> is usually re-C<#defined> in
1968 F<perl.h> as a simple macro call to the system's C<signbit()>.
1969 Users should just always call C<Perl_signbit()>.
1973 #if !defined(HAS_SIGNBIT)
1975 Perl_signbit(NV x) {
1976 # ifdef Perl_fp_class_nzero
1977 return Perl_fp_class_nzero(x);
1978 /* Try finding the high byte, and assume it's highest bit
1979 * is the sign. This assumption is probably wrong somewhere. */
1980 # elif defined(USE_LONG_DOUBLE) && LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_LITTLE_ENDIAN
1981 return (((unsigned char *)&x)[9] & 0x80);
1982 # elif defined(NV_LITTLE_ENDIAN)
1983 /* Note that NVSIZE is sizeof(NV), which would make the below be
1984 * wrong if the end bytes are unused, which happens with the x86
1985 * 80-bit long doubles, which is why take care of that above. */
1986 return (((unsigned char *)&x)[NVSIZE - 1] & 0x80);
1987 # elif defined(NV_BIG_ENDIAN)
1988 return (((unsigned char *)&x)[0] & 0x80);
1990 /* This last resort fallback is wrong for the negative zero. */
1991 return (x < 0.0) ? 1 : 0;
1997 * ex: set ts=8 sts=4 sw=4 et: