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> give the string to scan, C<*flags> gives
212 conversion flags, and C<result> should be C<NULL> or a pointer to an NV.
213 The scan stops at the end of the string, or the first invalid character.
214 Unless C<PERL_SCAN_SILENT_ILLDIGIT> is set in C<*flags>, encountering an
215 invalid character will also trigger a warning.
216 On return C<*len> is set to the length of the scanned string,
217 and C<*flags> gives output 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 the value to C<*result> (or the value is discarded if C<result>
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. If
227 C<PERL_SCAN_ALLOW_UNDERSCORES> is set in C<*flags> then the binary
228 number may use C<"_"> characters to separate digits.
230 =for apidoc Amnh||PERL_SCAN_ALLOW_UNDERSCORES
231 =for apidoc Amnh||PERL_SCAN_DISALLOW_PREFIX
232 =for apidoc Amnh||PERL_SCAN_GREATER_THAN_UV_MAX
233 =for apidoc Amnh||PERL_SCAN_SILENT_ILLDIGIT
234 =for apidoc Amnh||PERL_SCAN_TRAILING
238 Not documented yet because experimental is C<PERL_SCAN_SILENT_NON_PORTABLE
239 which suppresses any message for non-portable numbers that are still valid
244 Perl_grok_bin(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result)
246 const char *s = start;
251 const UV max_div_2 = UV_MAX / 2;
252 const bool allow_underscores = cBOOL(*flags & PERL_SCAN_ALLOW_UNDERSCORES);
253 bool overflowed = FALSE;
256 PERL_ARGS_ASSERT_GROK_BIN;
258 if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) {
259 /* strip off leading b or 0b.
260 for compatibility silently suffer "b" and "0b" as valid binary
263 if (isALPHA_FOLD_EQ(s[0], 'b')) {
267 else if (len >= 2 && s[0] == '0' && (isALPHA_FOLD_EQ(s[1], 'b'))) {
274 for (; len-- && (bit = *s); s++) {
275 if (bit == '0' || bit == '1') {
276 /* Write it in this wonky order with a goto to attempt to get the
277 compiler to make the common case integer-only loop pretty tight.
278 With gcc seems to be much straighter code than old scan_bin. */
281 if (value <= max_div_2) {
282 value = (value << 1) | (bit - '0');
285 /* Bah. We're just overflowed. */
286 /* diag_listed_as: Integer overflow in %s number */
287 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
288 "Integer overflow in binary number");
290 value_nv = (NV) value;
293 /* If an NV has not enough bits in its mantissa to
294 * represent a UV this summing of small low-order numbers
295 * is a waste of time (because the NV cannot preserve
296 * the low-order bits anyway): we could just remember when
297 * did we overflow and in the end just multiply value_nv by the
299 value_nv += (NV)(bit - '0');
302 if (bit == '_' && len && allow_underscores && (bit = s[1])
303 && (bit == '0' || bit == '1'))
309 if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT))
310 Perl_ck_warner(aTHX_ packWARN(WARN_DIGIT),
311 "Illegal binary digit '%c' ignored", *s);
315 if ( ( overflowed && value_nv > 4294967295.0)
317 || (!overflowed && value > 0xffffffff
318 && ! (*flags & PERL_SCAN_SILENT_NON_PORTABLE))
321 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
322 "Binary number > 0b11111111111111111111111111111111 non-portable");
329 *flags = PERL_SCAN_GREATER_THAN_UV_MAX;
338 converts a string representing a hex number to numeric form.
340 On entry C<start> and C<*len_p> give the string to scan, C<*flags> gives
341 conversion flags, and C<result> should be C<NULL> or a pointer to an NV.
342 The scan stops at the end of the string, or the first invalid character.
343 Unless C<PERL_SCAN_SILENT_ILLDIGIT> is set in C<*flags>, encountering an
344 invalid character will also trigger a warning.
345 On return C<*len> is set to the length of the scanned string,
346 and C<*flags> gives output flags.
348 If the value is <= C<UV_MAX> it is returned as a UV, the output flags are clear,
349 and nothing is written to C<*result>. If the value is > C<UV_MAX>, C<grok_hex>
350 returns C<UV_MAX>, sets C<PERL_SCAN_GREATER_THAN_UV_MAX> in the output flags,
351 and writes the value to C<*result> (or the value is discarded if C<result>
354 The hex number may optionally be prefixed with C<"0x"> or C<"x"> unless
355 C<PERL_SCAN_DISALLOW_PREFIX> is set in C<*flags> on entry. If
356 C<PERL_SCAN_ALLOW_UNDERSCORES> is set in C<*flags> then the hex
357 number may use C<"_"> characters to separate digits.
361 Not documented yet because experimental is C<PERL_SCAN_SILENT_NON_PORTABLE
362 which suppresses any message for non-portable numbers, but which are valid
367 Perl_grok_hex(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result)
369 const char *s = start;
373 const UV max_div_16 = UV_MAX / 16;
374 const bool allow_underscores = cBOOL(*flags & PERL_SCAN_ALLOW_UNDERSCORES);
375 bool overflowed = FALSE;
377 PERL_ARGS_ASSERT_GROK_HEX;
379 if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) {
380 /* strip off leading x or 0x.
381 for compatibility silently suffer "x" and "0x" as valid hex numbers.
384 if (isALPHA_FOLD_EQ(s[0], 'x')) {
388 else if (len >= 2 && s[0] == '0' && (isALPHA_FOLD_EQ(s[1], 'x'))) {
395 for (; len-- && *s; s++) {
397 /* Write it in this wonky order with a goto to attempt to get the
398 compiler to make the common case integer-only loop pretty tight.
399 With gcc seems to be much straighter code than old scan_hex. */
402 if (value <= max_div_16) {
403 value = (value << 4) | XDIGIT_VALUE(*s);
406 /* Bah. We're just overflowed. */
407 /* diag_listed_as: Integer overflow in %s number */
408 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
409 "Integer overflow in hexadecimal number");
411 value_nv = (NV) value;
414 /* If an NV has not enough bits in its mantissa to
415 * represent a UV this summing of small low-order numbers
416 * is a waste of time (because the NV cannot preserve
417 * the low-order bits anyway): we could just remember when
418 * did we overflow and in the end just multiply value_nv by the
419 * right amount of 16-tuples. */
420 value_nv += (NV) XDIGIT_VALUE(*s);
423 if (*s == '_' && len && allow_underscores && s[1]
430 if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT))
431 Perl_ck_warner(aTHX_ packWARN(WARN_DIGIT),
432 "Illegal hexadecimal digit '%c' ignored", *s);
436 if ( ( overflowed && value_nv > 4294967295.0)
438 || (!overflowed && value > 0xffffffff
439 && ! (*flags & PERL_SCAN_SILENT_NON_PORTABLE))
442 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
443 "Hexadecimal number > 0xffffffff non-portable");
450 *flags = PERL_SCAN_GREATER_THAN_UV_MAX;
459 converts a string representing an octal number to numeric form.
461 On entry C<start> and C<*len> give the string to scan, C<*flags> gives
462 conversion flags, and C<result> should be C<NULL> or a pointer to an NV.
463 The scan stops at the end of the string, or the first invalid character.
464 Unless C<PERL_SCAN_SILENT_ILLDIGIT> is set in C<*flags>, encountering an
465 8 or 9 will also trigger a warning.
466 On return C<*len> is set to the length of the scanned string,
467 and C<*flags> gives output flags.
469 If the value is <= C<UV_MAX> it is returned as a UV, the output flags are clear,
470 and nothing is written to C<*result>. If the value is > C<UV_MAX>, C<grok_oct>
471 returns C<UV_MAX>, sets C<PERL_SCAN_GREATER_THAN_UV_MAX> in the output flags,
472 and writes the value to C<*result> (or the value is discarded if C<result>
475 If C<PERL_SCAN_ALLOW_UNDERSCORES> is set in C<*flags> then the octal
476 number may use C<"_"> characters to separate digits.
480 Not documented yet because experimental is C<PERL_SCAN_SILENT_NON_PORTABLE>
481 which suppresses any message for non-portable numbers, but which are valid
486 Perl_grok_oct(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result)
488 const char *s = start;
492 const UV max_div_8 = UV_MAX / 8;
493 const bool allow_underscores = cBOOL(*flags & PERL_SCAN_ALLOW_UNDERSCORES);
494 bool overflowed = FALSE;
496 PERL_ARGS_ASSERT_GROK_OCT;
498 for (; len-- && *s; s++) {
500 /* Write it in this wonky order with a goto to attempt to get the
501 compiler to make the common case integer-only loop pretty tight.
505 if (value <= max_div_8) {
506 value = (value << 3) | OCTAL_VALUE(*s);
509 /* Bah. We're just overflowed. */
510 /* diag_listed_as: Integer overflow in %s number */
511 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
512 "Integer overflow in octal number");
514 value_nv = (NV) value;
517 /* If an NV has not enough bits in its mantissa to
518 * represent a UV this summing of small low-order numbers
519 * is a waste of time (because the NV cannot preserve
520 * the low-order bits anyway): we could just remember when
521 * did we overflow and in the end just multiply value_nv by the
522 * right amount of 8-tuples. */
523 value_nv += (NV) OCTAL_VALUE(*s);
526 if (*s == '_' && len && allow_underscores && isOCTAL(s[1])) {
531 /* Allow \octal to work the DWIM way (that is, stop scanning
532 * as soon as non-octal characters are seen, complain only if
533 * someone seems to want to use the digits eight and nine. Since we
534 * know it is not octal, then if isDIGIT, must be an 8 or 9). */
536 if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT))
537 Perl_ck_warner(aTHX_ packWARN(WARN_DIGIT),
538 "Illegal octal digit '%c' ignored", *s);
543 if ( ( overflowed && value_nv > 4294967295.0)
545 || (!overflowed && value > 0xffffffff
546 && ! (*flags & PERL_SCAN_SILENT_NON_PORTABLE))
549 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
550 "Octal number > 037777777777 non-portable");
557 *flags = PERL_SCAN_GREATER_THAN_UV_MAX;
566 For backwards compatibility. Use C<grok_bin> instead.
570 For backwards compatibility. Use C<grok_hex> instead.
574 For backwards compatibility. Use C<grok_oct> instead.
580 Perl_scan_bin(pTHX_ const char *start, STRLEN len, STRLEN *retlen)
583 I32 flags = *retlen ? PERL_SCAN_ALLOW_UNDERSCORES : 0;
584 const UV ruv = grok_bin (start, &len, &flags, &rnv);
586 PERL_ARGS_ASSERT_SCAN_BIN;
589 return (flags & PERL_SCAN_GREATER_THAN_UV_MAX) ? rnv : (NV)ruv;
593 Perl_scan_oct(pTHX_ const char *start, STRLEN len, STRLEN *retlen)
596 I32 flags = *retlen ? PERL_SCAN_ALLOW_UNDERSCORES : 0;
597 const UV ruv = grok_oct (start, &len, &flags, &rnv);
599 PERL_ARGS_ASSERT_SCAN_OCT;
602 return (flags & PERL_SCAN_GREATER_THAN_UV_MAX) ? rnv : (NV)ruv;
606 Perl_scan_hex(pTHX_ const char *start, STRLEN len, STRLEN *retlen)
609 I32 flags = *retlen ? PERL_SCAN_ALLOW_UNDERSCORES : 0;
610 const UV ruv = grok_hex (start, &len, &flags, &rnv);
612 PERL_ARGS_ASSERT_SCAN_HEX;
615 return (flags & PERL_SCAN_GREATER_THAN_UV_MAX) ? rnv : (NV)ruv;
619 =for apidoc grok_numeric_radix
621 Scan and skip for a numeric decimal separator (radix).
626 Perl_grok_numeric_radix(pTHX_ const char **sp, const char *send)
628 PERL_ARGS_ASSERT_GROK_NUMERIC_RADIX;
630 #ifdef USE_LOCALE_NUMERIC
632 if (IN_LC(LC_NUMERIC)) {
635 bool matches_radix = FALSE;
636 DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
638 STORE_LC_NUMERIC_FORCE_TO_UNDERLYING();
640 radix = SvPV(PL_numeric_radix_sv, len);
641 radix = savepvn(radix, len);
643 RESTORE_LC_NUMERIC();
645 if (*sp + len <= send) {
646 matches_radix = memEQ(*sp, radix, len);
659 /* always try "." if numeric radix didn't match because
660 * we may have data from different locales mixed */
661 if (*sp < send && **sp == '.') {
670 =for apidoc grok_infnan
672 Helper for C<grok_number()>, accepts various ways of spelling "infinity"
673 or "not a number", and returns one of the following flag combinations:
677 IS_NUMBER_INFINITY | IS_NUMBER_NEG
678 IS_NUMBER_NAN | IS_NUMBER_NEG
681 possibly |-ed with C<IS_NUMBER_TRAILING>.
683 If an infinity or a not-a-number is recognized, C<*sp> will point to
684 one byte past the end of the recognized string. If the recognition fails,
685 zero is returned, and C<*sp> will not move.
687 =for apidoc Amn|bool|IS_NUMBER_GREATER_THAN_UV_MAX
688 =for apidoc Amn|bool|IS_NUMBER_INFINITY
689 =for apidoc Amn|bool|IS_NUMBER_IN_UV
690 =for apidoc Amn|bool|IS_NUMBER_NAN
691 =for apidoc Amn|bool|IS_NUMBER_NEG
692 =for apidoc Amn|bool|IS_NUMBER_NOT_INT
698 Perl_grok_infnan(pTHX_ const char** sp, const char* send)
702 #if defined(NV_INF) || defined(NV_NAN)
703 bool odh = FALSE; /* one-dot-hash: 1.#INF */
705 PERL_ARGS_ASSERT_GROK_INFNAN;
708 s++; if (s == send) return 0;
710 else if (*s == '-') {
711 flags |= IS_NUMBER_NEG; /* Yes, -NaN happens. Incorrect but happens. */
712 s++; if (s == send) return 0;
716 /* Visual C: 1.#SNAN, -1.#QNAN, 1#INF, 1.#IND (maybe also 1.#NAN)
717 * Let's keep the dot optional. */
718 s++; if (s == send) return 0;
720 s++; if (s == send) return 0;
723 s++; if (s == send) return 0;
729 if (isALPHA_FOLD_EQ(*s, 'I')) {
730 /* INF or IND (1.#IND is "indeterminate", a certain type of NAN) */
732 s++; if (s == send || isALPHA_FOLD_NE(*s, 'N')) return 0;
733 s++; if (s == send) return 0;
734 if (isALPHA_FOLD_EQ(*s, 'F')) {
736 if (s < send && (isALPHA_FOLD_EQ(*s, 'I'))) {
738 flags | IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT | IS_NUMBER_TRAILING;
739 s++; if (s == send || isALPHA_FOLD_NE(*s, 'N')) return fail;
740 s++; if (s == send || isALPHA_FOLD_NE(*s, 'I')) return fail;
741 s++; if (s == send || isALPHA_FOLD_NE(*s, 'T')) return fail;
742 s++; if (s == send || isALPHA_FOLD_NE(*s, 'Y')) return fail;
745 while (*s == '0') { /* 1.#INF00 */
749 while (s < send && isSPACE(*s))
751 if (s < send && *s) {
752 flags |= IS_NUMBER_TRAILING;
754 flags |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT;
756 else if (isALPHA_FOLD_EQ(*s, 'D') && odh) { /* 1.#IND */
758 flags |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT;
759 while (*s == '0') { /* 1.#IND00 */
763 flags |= IS_NUMBER_TRAILING;
769 /* Maybe NAN of some sort */
771 if (isALPHA_FOLD_EQ(*s, 'S') || isALPHA_FOLD_EQ(*s, 'Q')) {
773 /* XXX do something with the snan/qnan difference */
774 s++; if (s == send) return 0;
777 if (isALPHA_FOLD_EQ(*s, 'N')) {
778 s++; if (s == send || isALPHA_FOLD_NE(*s, 'A')) return 0;
779 s++; if (s == send || isALPHA_FOLD_NE(*s, 'N')) return 0;
782 flags |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT;
784 /* NaN can be followed by various stuff (NaNQ, NaNS), but
785 * there are also multiple different NaN values, and some
786 * implementations output the "payload" values,
787 * e.g. NaN123, NAN(abc), while some legacy implementations
788 * have weird stuff like NaN%. */
789 if (isALPHA_FOLD_EQ(*s, 'q') ||
790 isALPHA_FOLD_EQ(*s, 's')) {
791 /* "nanq" or "nans" are ok, though generating
792 * these portably is tricky. */
796 /* C99 style "nan(123)" or Perlish equivalent "nan($uv)". */
800 return flags | IS_NUMBER_TRAILING;
803 while (t < send && *t && *t != ')') {
807 return flags | IS_NUMBER_TRAILING;
812 if (s[0] == '0' && s + 2 < t &&
813 isALPHA_FOLD_EQ(s[1], 'x') &&
816 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
817 nanval = grok_hex(s, &len, &flags, NULL);
818 if ((flags & PERL_SCAN_GREATER_THAN_UV_MAX)) {
821 nantype = IS_NUMBER_IN_UV;
824 } else if (s[0] == '0' && s + 2 < t &&
825 isALPHA_FOLD_EQ(s[1], 'b') &&
826 (s[2] == '0' || s[2] == '1')) {
828 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
829 nanval = grok_bin(s, &len, &flags, NULL);
830 if ((flags & PERL_SCAN_GREATER_THAN_UV_MAX)) {
833 nantype = IS_NUMBER_IN_UV;
839 grok_number_flags(s, t - s, &nanval,
841 PERL_SCAN_ALLOW_UNDERSCORES);
842 /* Unfortunately grok_number_flags() doesn't
843 * tell how far we got and the ')' will always
844 * be "trailing", so we need to double-check
845 * whether we had something dubious. */
846 for (u = s; u < t; u++) {
848 flags |= IS_NUMBER_TRAILING;
855 /* XXX Doesn't do octal: nan("0123").
856 * Probably not a big loss. */
858 if ((nantype & IS_NUMBER_NOT_INT) ||
859 !(nantype && IS_NUMBER_IN_UV)) {
860 /* XXX the nanval is currently unused, that is,
861 * not inserted as the NaN payload of the NV.
862 * But the above code already parses the C99
863 * nan(...) format. See below, and see also
864 * the nan() in POSIX.xs.
866 * Certain configuration combinations where
867 * NVSIZE is greater than UVSIZE mean that
868 * a single UV cannot contain all the possible
869 * NaN payload bits. There would need to be
870 * some more generic syntax than "nan($uv)".
872 * Issues to keep in mind:
874 * (1) In most common cases there would
875 * not be an integral number of bytes that
876 * could be set, only a certain number of bits.
877 * For example for the common case of
878 * NVSIZE == UVSIZE == 8 there is room for 52
879 * bits in the payload, but the most significant
880 * bit is commonly reserved for the
881 * signaling/quiet bit, leaving 51 bits.
882 * Furthermore, the C99 nan() is supposed
883 * to generate quiet NaNs, so it is doubtful
884 * whether it should be able to generate
885 * signaling NaNs. For the x86 80-bit doubles
886 * (if building a long double Perl) there would
887 * be 62 bits (s/q bit being the 63rd).
889 * (2) Endianness of the payload bits. If the
890 * payload is specified as an UV, the low-order
891 * bits of the UV are naturally little-endianed
892 * (rightmost) bits of the payload. The endianness
893 * of UVs and NVs can be different. */
897 flags |= IS_NUMBER_TRAILING;
900 /* Looked like nan(...), but no close paren. */
901 flags |= IS_NUMBER_TRAILING;
904 while (s < send && isSPACE(*s))
906 if (s < send && *s) {
907 /* Note that we here implicitly accept (parse as
908 * "nan", but with warnings) also any other weird
909 * trailing stuff for "nan". In the above we just
910 * check that if we got the C99-style "nan(...)",
911 * the "..." looks sane.
912 * If in future we accept more ways of specifying
913 * the nan payload, the accepting would happen around
915 flags |= IS_NUMBER_TRAILING;
924 while (s < send && isSPACE(*s))
928 PERL_UNUSED_ARG(send);
929 #endif /* #if defined(NV_INF) || defined(NV_NAN) */
935 =for apidoc grok_number_flags
937 Recognise (or not) a number. The type of the number is returned
938 (0 if unrecognised), otherwise it is a bit-ORed combination of
939 C<IS_NUMBER_IN_UV>, C<IS_NUMBER_GREATER_THAN_UV_MAX>, C<IS_NUMBER_NOT_INT>,
940 C<IS_NUMBER_NEG>, C<IS_NUMBER_INFINITY>, C<IS_NUMBER_NAN> (defined in perl.h).
942 If the value of the number can fit in a UV, it is returned in C<*valuep>.
943 C<IS_NUMBER_IN_UV> will be set to indicate that C<*valuep> is valid, C<IS_NUMBER_IN_UV>
944 will never be set unless C<*valuep> is valid, but C<*valuep> may have been assigned
945 to during processing even though C<IS_NUMBER_IN_UV> is not set on return.
946 If C<valuep> is C<NULL>, C<IS_NUMBER_IN_UV> will be set for the same cases as when
947 C<valuep> is non-C<NULL>, but no actual assignment (or SEGV) will occur.
949 C<IS_NUMBER_NOT_INT> will be set with C<IS_NUMBER_IN_UV> if trailing decimals were
950 seen (in which case C<*valuep> gives the true value truncated to an integer), and
951 C<IS_NUMBER_NEG> if the number is negative (in which case C<*valuep> holds the
952 absolute value). C<IS_NUMBER_IN_UV> is not set if e notation was used or the
953 number is larger than a UV.
955 C<flags> allows only C<PERL_SCAN_TRAILING>, which allows for trailing
956 non-numeric text on an otherwise successful I<grok>, setting
957 C<IS_NUMBER_TRAILING> on the result.
959 =for apidoc grok_number
961 Identical to C<grok_number_flags()> with C<flags> set to zero.
966 Perl_grok_number(pTHX_ const char *pv, STRLEN len, UV *valuep)
968 PERL_ARGS_ASSERT_GROK_NUMBER;
970 return grok_number_flags(pv, len, valuep, 0);
973 static const UV uv_max_div_10 = UV_MAX / 10;
974 static const U8 uv_max_mod_10 = UV_MAX % 10;
977 Perl_grok_number_flags(pTHX_ const char *pv, STRLEN len, UV *valuep, U32 flags)
980 const char * const send = pv + len;
984 PERL_ARGS_ASSERT_GROK_NUMBER_FLAGS;
986 while (s < send && isSPACE(*s))
990 } else if (*s == '-') {
992 numtype = IS_NUMBER_NEG;
1000 /* The first digit (after optional sign): note that might
1001 * also point to "infinity" or "nan", or "1.#INF". */
1004 /* next must be digit or the radix separator or beginning of infinity/nan */
1006 /* UVs are at least 32 bits, so the first 9 decimal digits cannot
1008 UV value = *s - '0';
1009 /* This construction seems to be more optimiser friendly.
1010 (without it gcc does the isDIGIT test and the *s - '0' separately)
1011 With it gcc on arm is managing 6 instructions (6 cycles) per digit.
1012 In theory the optimiser could deduce how far to unroll the loop
1013 before checking for overflow. */
1015 int digit = *s - '0';
1016 if (inRANGE(digit, 0, 9)) {
1017 value = value * 10 + digit;
1020 if (inRANGE(digit, 0, 9)) {
1021 value = value * 10 + digit;
1024 if (inRANGE(digit, 0, 9)) {
1025 value = value * 10 + digit;
1028 if (inRANGE(digit, 0, 9)) {
1029 value = value * 10 + digit;
1032 if (inRANGE(digit, 0, 9)) {
1033 value = value * 10 + digit;
1036 if (inRANGE(digit, 0, 9)) {
1037 value = value * 10 + digit;
1040 if (inRANGE(digit, 0, 9)) {
1041 value = value * 10 + digit;
1044 if (inRANGE(digit, 0, 9)) {
1045 value = value * 10 + digit;
1047 /* Now got 9 digits, so need to check
1048 each time for overflow. */
1050 while ( inRANGE(digit, 0, 9)
1051 && (value < uv_max_div_10
1052 || (value == uv_max_div_10
1053 && digit <= uv_max_mod_10))) {
1054 value = value * 10 + digit;
1060 if (inRANGE(digit, 0, 9)
1062 /* value overflowed.
1063 skip the remaining digits, don't
1064 worry about setting *valuep. */
1067 } while (s < send && isDIGIT(*s));
1069 IS_NUMBER_GREATER_THAN_UV_MAX;
1089 numtype |= IS_NUMBER_IN_UV;
1094 if (GROK_NUMERIC_RADIX(&s, send)) {
1095 numtype |= IS_NUMBER_NOT_INT;
1096 while (s < send && isDIGIT(*s)) /* optional digits after the radix */
1100 else if (GROK_NUMERIC_RADIX(&s, send)) {
1101 numtype |= IS_NUMBER_NOT_INT | IS_NUMBER_IN_UV; /* valuep assigned below */
1102 /* no digits before the radix means we need digits after it */
1103 if (s < send && isDIGIT(*s)) {
1106 } while (s < send && isDIGIT(*s));
1108 /* integer approximation is valid - it's 0. */
1116 if (s > d && s < send) {
1117 /* we can have an optional exponent part */
1118 if (isALPHA_FOLD_EQ(*s, 'e')) {
1120 if (s < send && (*s == '-' || *s == '+'))
1122 if (s < send && isDIGIT(*s)) {
1125 } while (s < send && isDIGIT(*s));
1127 else if (flags & PERL_SCAN_TRAILING)
1128 return numtype | IS_NUMBER_TRAILING;
1132 /* The only flag we keep is sign. Blow away any "it's UV" */
1133 numtype &= IS_NUMBER_NEG;
1134 numtype |= IS_NUMBER_NOT_INT;
1137 while (s < send && isSPACE(*s))
1141 if (memEQs(pv, len, "0 but true")) {
1144 return IS_NUMBER_IN_UV;
1146 /* We could be e.g. at "Inf" or "NaN", or at the "#" of "1.#INF". */
1147 if ((s + 2 < send) && strchr("inqs#", toFOLD(*s))) {
1148 /* Really detect inf/nan. Start at d, not s, since the above
1149 * code might have already consumed the "1." or "1". */
1150 const int infnan = Perl_grok_infnan(aTHX_ &d, send);
1151 if ((infnan & IS_NUMBER_INFINITY)) {
1152 return (numtype | infnan); /* Keep sign for infinity. */
1154 else if ((infnan & IS_NUMBER_NAN)) {
1155 return (numtype | infnan) & ~IS_NUMBER_NEG; /* Clear sign for nan. */
1158 else if (flags & PERL_SCAN_TRAILING) {
1159 return numtype | IS_NUMBER_TRAILING;
1166 =for apidoc grok_atoUV
1168 parse a string, looking for a decimal unsigned integer.
1170 On entry, C<pv> points to the beginning of the string;
1171 C<valptr> points to a UV that will receive the converted value, if found;
1172 C<endptr> is either NULL or points to a variable that points to one byte
1173 beyond the point in C<pv> that this routine should examine.
1174 If C<endptr> is NULL, C<pv> is assumed to be NUL-terminated.
1176 Returns FALSE if C<pv> doesn't represent a valid unsigned integer value (with
1177 no leading zeros). Otherwise it returns TRUE, and sets C<*valptr> to that
1180 If you constrain the portion of C<pv> that is looked at by this function (by
1181 passing a non-NULL C<endptr>), and if the intial bytes of that portion form a
1182 valid value, it will return TRUE, setting C<*endptr> to the byte following the
1183 final digit of the value. But if there is no constraint at what's looked at,
1184 all of C<pv> must be valid in order for TRUE to be returned.
1186 The only characters this accepts are the decimal digits '0'..'9'.
1188 As opposed to L<atoi(3)> or L<strtol(3)>, C<grok_atoUV> does NOT allow optional
1189 leading whitespace, nor negative inputs. If such features are required, the
1190 calling code needs to explicitly implement those.
1192 Note that this function returns FALSE for inputs that would overflow a UV,
1193 or have leading zeros. Thus a single C<0> is accepted, but not C<00> nor
1194 C<01>, C<002>, I<etc>.
1196 Background: C<atoi> has severe problems with illegal inputs, it cannot be
1197 used for incremental parsing, and therefore should be avoided
1198 C<atoi> and C<strtol> are also affected by locale settings, which can also be
1199 seen as a bug (global state controlled by user environment).
1206 Perl_grok_atoUV(const char *pv, UV *valptr, const char** endptr)
1210 const char* end2; /* Used in case endptr is NULL. */
1211 UV val = 0; /* The parsed value. */
1213 PERL_ARGS_ASSERT_GROK_ATOUV;
1219 end2 = s + strlen(s);
1229 /* Single-digit inputs are quite common. */
1231 if (s < *eptr && isDIGIT(*s)) {
1232 /* Fail on extra leading zeros. */
1235 while (s < *eptr && isDIGIT(*s)) {
1236 /* This could be unrolled like in grok_number(), but
1237 * the expected uses of this are not speed-needy, and
1238 * unlikely to need full 64-bitness. */
1239 const U8 digit = *s++ - '0';
1240 if (val < uv_max_div_10 ||
1241 (val == uv_max_div_10 && digit <= uv_max_mod_10)) {
1242 val = val * 10 + digit;
1249 if (endptr == NULL) {
1251 return FALSE; /* If endptr is NULL, no trailing non-digits allowed. */
1264 S_mulexp10(NV value, I32 exponent)
1276 /* On OpenVMS VAX we by default use the D_FLOAT double format,
1277 * and that format does not have *easy* capabilities [1] for
1278 * overflowing doubles 'silently' as IEEE fp does. We also need
1279 * to support G_FLOAT on both VAX and Alpha, and though the exponent
1280 * range is much larger than D_FLOAT it still doesn't do silent
1281 * overflow. Therefore we need to detect early whether we would
1282 * overflow (this is the behaviour of the native string-to-float
1283 * conversion routines, and therefore of native applications, too).
1285 * [1] Trying to establish a condition handler to trap floating point
1286 * exceptions is not a good idea. */
1288 /* In UNICOS and in certain Cray models (such as T90) there is no
1289 * IEEE fp, and no way at all from C to catch fp overflows gracefully.
1290 * There is something you can do if you are willing to use some
1291 * inline assembler: the instruction is called DFI-- but that will
1292 * disable *all* floating point interrupts, a little bit too large
1293 * a hammer. Therefore we need to catch potential overflows before
1296 #if ((defined(VMS) && !defined(_IEEE_FP)) || defined(_UNICOS) || defined(DOUBLE_IS_VAX_FLOAT)) && defined(NV_MAX_10_EXP)
1298 const NV exp_v = log10(value);
1299 if (exponent >= NV_MAX_10_EXP || exponent + exp_v >= NV_MAX_10_EXP)
1302 if (-(exponent + exp_v) >= NV_MAX_10_EXP)
1304 while (-exponent >= NV_MAX_10_EXP) {
1305 /* combination does not overflow, but 10^(-exponent) does */
1315 exponent = -exponent;
1316 #ifdef NV_MAX_10_EXP
1317 /* for something like 1234 x 10^-309, the action of calculating
1318 * the intermediate value 10^309 then returning 1234 / (10^309)
1319 * will fail, since 10^309 becomes infinity. In this case try to
1320 * refactor it as 123 / (10^308) etc.
1322 while (value && exponent > NV_MAX_10_EXP) {
1330 #if defined(__osf__)
1331 /* Even with cc -ieee + ieee_set_fp_control(IEEE_TRAP_ENABLE_INV)
1332 * Tru64 fp behavior on inf/nan is somewhat broken. Another way
1333 * to do this would be ieee_set_fp_control(IEEE_TRAP_ENABLE_OVF)
1334 * but that breaks another set of infnan.t tests. */
1335 # define FP_OVERFLOWS_TO_ZERO
1337 for (bit = 1; exponent; bit <<= 1) {
1338 if (exponent & bit) {
1341 #ifdef FP_OVERFLOWS_TO_ZERO
1344 return value < 0 ? -NV_INF : NV_INF;
1346 return value < 0 ? -FLT_MAX : FLT_MAX;
1349 /* Floating point exceptions are supposed to be turned off,
1350 * but if we're obviously done, don't risk another iteration.
1352 if (exponent == 0) break;
1356 return negative ? value / result : value * result;
1358 #endif /* #ifndef Perl_strtod */
1361 # define ATOF(s, x) my_atof2(s, &x)
1363 # define ATOF(s, x) Perl_atof2(s, x)
1367 Perl_my_atof(pTHX_ const char* s)
1369 /* 's' must be NUL terminated */
1373 PERL_ARGS_ASSERT_MY_ATOF;
1375 #if ! defined(USE_LOCALE_NUMERIC)
1382 DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
1383 STORE_LC_NUMERIC_SET_TO_NEEDED();
1384 if (! (PL_numeric_radix_sv && IN_LC(LC_NUMERIC))) {
1389 /* Look through the string for the first thing that looks like a
1390 * decimal point: either the value in the current locale or the
1391 * standard fallback of '.'. The one which appears earliest in the
1392 * input string is the one that we should have atof look for. Note
1393 * that we have to determine this beforehand because on some
1394 * systems, Perl_atof2 is just a wrapper around the system's atof.
1396 const char * const standard_pos = strchr(s, '.');
1397 const char * const local_pos
1398 = strstr(s, SvPV_nolen(PL_numeric_radix_sv));
1399 const bool use_standard_radix
1400 = standard_pos && (!local_pos || standard_pos < local_pos);
1402 if (use_standard_radix) {
1403 SET_NUMERIC_STANDARD();
1404 LOCK_LC_NUMERIC_STANDARD();
1409 if (use_standard_radix) {
1410 UNLOCK_LC_NUMERIC_STANDARD();
1411 SET_NUMERIC_UNDERLYING();
1414 RESTORE_LC_NUMERIC();
1422 #if defined(NV_INF) || defined(NV_NAN)
1425 # pragma warning(push)
1426 # pragma warning(disable:4756;disable:4056)
1429 S_my_atof_infnan(pTHX_ const char* s, bool negative, const char* send, NV* value)
1431 const char *p0 = negative ? s - 1 : s;
1433 const int infnan = grok_infnan(&p, send);
1434 if (infnan && p != p0) {
1435 /* If we can generate inf/nan directly, let's do so. */
1437 if ((infnan & IS_NUMBER_INFINITY)) {
1438 *value = (infnan & IS_NUMBER_NEG) ? -NV_INF: NV_INF;
1443 if ((infnan & IS_NUMBER_NAN)) {
1449 /* If still here, we didn't have either NV_INF or NV_NAN,
1450 * and can try falling back to native strtod/strtold.
1452 * The native interface might not recognize all the possible
1453 * inf/nan strings Perl recognizes. What we can try
1454 * is to try faking the input. We will try inf/-inf/nan
1455 * as the most promising/portable input. */
1457 const char* fake = "silence compiler warning";
1461 if ((infnan & IS_NUMBER_INFINITY)) {
1462 fake = ((infnan & IS_NUMBER_NEG)) ? "-inf" : "inf";
1466 if ((infnan & IS_NUMBER_NAN)) {
1470 assert(strNE(fake, "silence compiler warning"));
1471 nv = S_strtod(aTHX_ fake, &endp);
1474 if ((infnan & IS_NUMBER_INFINITY)) {
1479 /* last resort, may generate SIGFPE */
1480 *value = Perl_exp((NV)1e9);
1481 if ((infnan & IS_NUMBER_NEG))
1484 return (char*)p; /* p, not endp */
1488 if ((infnan & IS_NUMBER_NAN)) {
1493 /* last resort, may generate SIGFPE */
1494 *value = Perl_log((NV)-1.0);
1496 return (char*)p; /* p, not endp */
1501 #endif /* #ifdef Perl_strtod */
1506 # pragma warning(pop)
1509 #endif /* if defined(NV_INF) || defined(NV_NAN) */
1512 Perl_my_atof2(pTHX_ const char* orig, NV* value)
1514 PERL_ARGS_ASSERT_MY_ATOF2;
1515 return my_atof3(orig, value, 0);
1519 Perl_my_atof3(pTHX_ const char* orig, NV* value, const STRLEN len)
1521 const char* s = orig;
1522 NV result[3] = {0.0, 0.0, 0.0};
1523 #if defined(USE_PERL_ATOF) || defined(Perl_strtod)
1524 const char* send = s + ((len != 0)
1526 : strlen(orig)); /* one past the last */
1529 #if defined(USE_PERL_ATOF) && !defined(Perl_strtod)
1530 UV accumulator[2] = {0,0}; /* before/after dp */
1531 bool seen_digit = 0;
1532 I32 exp_adjust[2] = {0,0};
1533 I32 exp_acc[2] = {-1, -1};
1534 /* the current exponent adjust for the accumulators */
1539 I32 sig_digits = 0; /* noof significant digits seen so far */
1542 #if defined(USE_PERL_ATOF) || defined(Perl_strtod)
1543 PERL_ARGS_ASSERT_MY_ATOF3;
1545 /* leading whitespace */
1546 while (s < send && isSPACE(*s))
1564 if ((endp = S_my_atof_infnan(aTHX_ s, negative, send, value)))
1567 /* strtold() accepts 0x-prefixed hex and in POSIX implementations,
1568 0b-prefixed binary numbers, which is backward incompatible
1570 if ((len == 0 || len >= 2) && *s == '0' &&
1571 (isALPHA_FOLD_EQ(s[1], 'x') || isALPHA_FOLD_EQ(s[1], 'b'))) {
1576 /* If the length is passed in, the input string isn't NUL-terminated,
1577 * and in it turns out the function below assumes it is; therefore we
1578 * create a copy and NUL-terminate that */
1580 Newx(copy, len + 1, char);
1581 Copy(orig, copy, len, char);
1583 s = copy + (s - orig);
1586 result[2] = S_strtod(aTHX_ s, &endp);
1588 /* If we created a copy, 'endp' is in terms of that. Convert back to
1591 s = (s - copy) + (char *) orig;
1592 endp = (endp - copy) + (char *) orig;
1597 *value = negative ? -result[2] : result[2];
1602 #elif defined(USE_PERL_ATOF)
1604 /* There is no point in processing more significant digits
1605 * than the NV can hold. Note that NV_DIG is a lower-bound value,
1606 * while we need an upper-bound value. We add 2 to account for this;
1607 * since it will have been conservative on both the first and last digit.
1608 * For example a 32-bit mantissa with an exponent of 4 would have
1609 * exact values in the set
1617 * where for the purposes of calculating NV_DIG we would have to discount
1618 * both the first and last digit, since neither can hold all values from
1619 * 0..9; but for calculating the value we must examine those two digits.
1621 #ifdef MAX_SIG_DIG_PLUS
1622 /* It is not necessarily the case that adding 2 to NV_DIG gets all the
1623 possible digits in a NV, especially if NVs are not IEEE compliant
1624 (e.g., long doubles on IRIX) - Allen <allens@cpan.org> */
1625 # define MAX_SIG_DIGITS (NV_DIG+MAX_SIG_DIG_PLUS)
1627 # define MAX_SIG_DIGITS (NV_DIG+2)
1630 /* the max number we can accumulate in a UV, and still safely do 10*N+9 */
1631 #define MAX_ACCUMULATE ( (UV) ((UV_MAX - 9)/10))
1633 #if defined(NV_INF) || defined(NV_NAN)
1636 if ((endp = S_my_atof_infnan(aTHX_ s, negative, send, value)))
1641 /* we accumulate digits into an integer; when this becomes too
1642 * large, we add the total to NV and start again */
1652 /* don't start counting until we see the first significant
1653 * digit, eg the 5 in 0.00005... */
1654 if (!sig_digits && digit == 0)
1657 if (++sig_digits > MAX_SIG_DIGITS) {
1658 /* limits of precision reached */
1660 ++accumulator[seen_dp];
1661 } else if (digit == 5) {
1662 if (old_digit % 2) { /* round to even - Allen */
1663 ++accumulator[seen_dp];
1671 /* skip remaining digits */
1672 while (s < send && isDIGIT(*s)) {
1678 /* warn of loss of precision? */
1681 if (accumulator[seen_dp] > MAX_ACCUMULATE) {
1682 /* add accumulator to result and start again */
1683 result[seen_dp] = S_mulexp10(result[seen_dp],
1685 + (NV)accumulator[seen_dp];
1686 accumulator[seen_dp] = 0;
1687 exp_acc[seen_dp] = 0;
1689 accumulator[seen_dp] = accumulator[seen_dp] * 10 + digit;
1693 else if (!seen_dp && GROK_NUMERIC_RADIX(&s, send)) {
1695 if (sig_digits > MAX_SIG_DIGITS) {
1696 while (s < send && isDIGIT(*s)) {
1707 result[0] = S_mulexp10(result[0], exp_acc[0]) + (NV)accumulator[0];
1709 result[1] = S_mulexp10(result[1], exp_acc[1]) + (NV)accumulator[1];
1712 if (s < send && seen_digit && (isALPHA_FOLD_EQ(*s, 'e'))) {
1713 bool expnegative = 0;
1723 while (s < send && isDIGIT(*s))
1724 exponent = exponent * 10 + (*s++ - '0');
1726 exponent = -exponent;
1729 /* now apply the exponent */
1732 result[2] = S_mulexp10(result[0],exponent+exp_adjust[0])
1733 + S_mulexp10(result[1],exponent-exp_adjust[1]);
1735 result[2] = S_mulexp10(result[0],exponent+exp_adjust[0]);
1738 /* now apply the sign */
1740 result[2] = -result[2];
1741 #endif /* USE_PERL_ATOF */
1747 =for apidoc isinfnan
1749 C<Perl_isinfnan()> is utility function that returns true if the NV
1750 argument is either an infinity or a C<NaN>, false otherwise. To test
1751 in more detail, use C<Perl_isinf()> and C<Perl_isnan()>.
1753 This is also the logical inverse of Perl_isfinite().
1758 Perl_isinfnan(NV nv)
1760 PERL_UNUSED_ARG(nv);
1775 Checks whether the argument would be either an infinity or C<NaN> when used
1776 as a number, but is careful not to trigger non-numeric or uninitialized
1777 warnings. it assumes the caller has done C<SvGETMAGIC(sv)> already.
1783 Perl_isinfnansv(pTHX_ SV *sv)
1785 PERL_ARGS_ASSERT_ISINFNANSV;
1789 return Perl_isinfnan(SvNVX(sv));
1794 const char *s = SvPV_nomg_const(sv, len);
1795 return cBOOL(grok_infnan(&s, s+len));
1800 /* C99 has truncl, pre-C99 Solaris had aintl. We can use either with
1801 * copysignl to emulate modfl, which is in some platforms missing or
1803 # if defined(HAS_TRUNCL) && defined(HAS_COPYSIGNL)
1805 Perl_my_modfl(long double x, long double *ip)
1808 return (x == *ip ? copysignl(0.0L, x) : x - *ip);
1810 # elif defined(HAS_AINTL) && defined(HAS_COPYSIGNL)
1812 Perl_my_modfl(long double x, long double *ip)
1815 return (x == *ip ? copysignl(0.0L, x) : x - *ip);
1820 /* Similarly, with ilogbl and scalbnl we can emulate frexpl. */
1821 #if ! defined(HAS_FREXPL) && defined(HAS_ILOGBL) && defined(HAS_SCALBNL)
1823 Perl_my_frexpl(long double x, int *e) {
1824 *e = x == 0.0L ? 0 : ilogbl(x) + 1;
1825 return (scalbnl(x, -*e));
1830 =for apidoc Perl_signbit
1832 Return a non-zero integer if the sign bit on an NV is set, and 0 if
1835 If F<Configure> detects this system has a C<signbit()> that will work with
1836 our NVs, then we just use it via the C<#define> in F<perl.h>. Otherwise,
1837 fall back on this implementation. The main use of this function
1838 is catching C<-0.0>.
1840 C<Configure> notes: This function is called C<'Perl_signbit'> instead of a
1841 plain C<'signbit'> because it is easy to imagine a system having a C<signbit()>
1842 function or macro that doesn't happen to work with our particular choice
1843 of NVs. We shouldn't just re-C<#define> C<signbit> as C<Perl_signbit> and expect
1844 the standard system headers to be happy. Also, this is a no-context
1845 function (no C<pTHX_>) because C<Perl_signbit()> is usually re-C<#defined> in
1846 F<perl.h> as a simple macro call to the system's C<signbit()>.
1847 Users should just always call C<Perl_signbit()>.
1851 #if !defined(HAS_SIGNBIT)
1853 Perl_signbit(NV x) {
1854 # ifdef Perl_fp_class_nzero
1855 return Perl_fp_class_nzero(x);
1856 /* Try finding the high byte, and assume it's highest bit
1857 * is the sign. This assumption is probably wrong somewhere. */
1858 # elif defined(USE_LONG_DOUBLE) && LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_LITTLE_ENDIAN
1859 return (((unsigned char *)&x)[9] & 0x80);
1860 # elif defined(NV_LITTLE_ENDIAN)
1861 /* Note that NVSIZE is sizeof(NV), which would make the below be
1862 * wrong if the end bytes are unused, which happens with the x86
1863 * 80-bit long doubles, which is why take care of that above. */
1864 return (((unsigned char *)&x)[NVSIZE - 1] & 0x80);
1865 # elif defined(NV_BIG_ENDIAN)
1866 return (((unsigned char *)&x)[0] & 0x80);
1868 /* This last resort fallback is wrong for the negative zero. */
1869 return (x < 0.0) ? 1 : 0;
1875 * ex: set ts=8 sts=4 sw=4 et: