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
21 This file contains all the stuff needed by perl for manipulating numeric
22 values, including such things as replacements for the OS's atof() function
29 #define PERL_IN_NUMERIC_C
33 Perl_cast_ulong(pTHX_ NV f)
37 return f < I32_MIN ? (U32) I32_MIN : (U32)(I32) f;
40 if (f < U32_MAX_P1_HALF)
43 return ((U32) f) | (1 + U32_MAX >> 1);
48 return f > 0 ? U32_MAX : 0 /* NaN */;
52 Perl_cast_i32(pTHX_ NV f)
56 return f < I32_MIN ? I32_MIN : (I32) f;
59 if (f < U32_MAX_P1_HALF)
62 return (I32)(((U32) f) | (1 + U32_MAX >> 1));
67 return f > 0 ? (I32)U32_MAX : 0 /* NaN */;
71 Perl_cast_iv(pTHX_ NV f)
75 return f < IV_MIN ? IV_MIN : (IV) f;
78 /* For future flexibility allowing for sizeof(UV) >= sizeof(IV) */
79 if (f < UV_MAX_P1_HALF)
82 return (IV)(((UV) f) | (1 + UV_MAX >> 1));
87 return f > 0 ? (IV)UV_MAX : 0 /* NaN */;
91 Perl_cast_uv(pTHX_ NV f)
95 return f < IV_MIN ? (UV) IV_MIN : (UV)(IV) f;
98 if (f < UV_MAX_P1_HALF)
101 return ((UV) f) | (1 + UV_MAX >> 1);
106 return f > 0 ? UV_MAX : 0 /* NaN */;
112 converts a string representing a binary number to numeric form.
114 On entry I<start> and I<*len> give the string to scan, I<*flags> gives
115 conversion flags, and I<result> should be NULL or a pointer to an NV.
116 The scan stops at the end of the string, or the first invalid character.
117 Unless C<PERL_SCAN_SILENT_ILLDIGIT> is set in I<*flags>, encountering an
118 invalid character will also trigger a warning.
119 On return I<*len> is set to the length of the scanned string,
120 and I<*flags> gives output flags.
122 If the value is <= C<UV_MAX> it is returned as a UV, the output flags are clear,
123 and nothing is written to I<*result>. If the value is > UV_MAX C<grok_bin>
124 returns UV_MAX, sets C<PERL_SCAN_GREATER_THAN_UV_MAX> in the output flags,
125 and writes the value to I<*result> (or the value is discarded if I<result>
128 The binary number may optionally be prefixed with "0b" or "b" unless
129 C<PERL_SCAN_DISALLOW_PREFIX> is set in I<*flags> on entry. If
130 C<PERL_SCAN_ALLOW_UNDERSCORES> is set in I<*flags> then the binary
131 number may use '_' characters to separate digits.
135 Not documented yet because experimental is C<PERL_SCAN_SILENT_NON_PORTABLE
136 which suppresses any message for non-portable numbers that are still valid
141 Perl_grok_bin(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result)
143 const char *s = start;
148 const UV max_div_2 = UV_MAX / 2;
149 const bool allow_underscores = cBOOL(*flags & PERL_SCAN_ALLOW_UNDERSCORES);
150 bool overflowed = FALSE;
153 PERL_ARGS_ASSERT_GROK_BIN;
155 if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) {
156 /* strip off leading b or 0b.
157 for compatibility silently suffer "b" and "0b" as valid binary
160 if (s[0] == 'b' || s[0] == 'B') {
164 else if (len >= 2 && s[0] == '0' && (s[1] == 'b' || s[1] == 'B')) {
171 for (; len-- && (bit = *s); s++) {
172 if (bit == '0' || bit == '1') {
173 /* Write it in this wonky order with a goto to attempt to get the
174 compiler to make the common case integer-only loop pretty tight.
175 With gcc seems to be much straighter code than old scan_bin. */
178 if (value <= max_div_2) {
179 value = (value << 1) | (bit - '0');
182 /* Bah. We're just overflowed. */
183 /* diag_listed_as: Integer overflow in %s number */
184 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
185 "Integer overflow in binary number");
187 value_nv = (NV) value;
190 /* If an NV has not enough bits in its mantissa to
191 * represent a UV this summing of small low-order numbers
192 * is a waste of time (because the NV cannot preserve
193 * the low-order bits anyway): we could just remember when
194 * did we overflow and in the end just multiply value_nv by the
196 value_nv += (NV)(bit - '0');
199 if (bit == '_' && len && allow_underscores && (bit = s[1])
200 && (bit == '0' || bit == '1'))
206 if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT))
207 Perl_ck_warner(aTHX_ packWARN(WARN_DIGIT),
208 "Illegal binary digit '%c' ignored", *s);
212 if ( ( overflowed && value_nv > 4294967295.0)
214 || (!overflowed && value > 0xffffffff
215 && ! (*flags & PERL_SCAN_SILENT_NON_PORTABLE))
218 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
219 "Binary number > 0b11111111111111111111111111111111 non-portable");
226 *flags = PERL_SCAN_GREATER_THAN_UV_MAX;
235 converts a string representing a hex number to numeric form.
237 On entry I<start> and I<*len_p> give the string to scan, I<*flags> gives
238 conversion flags, and I<result> should be NULL or a pointer to an NV.
239 The scan stops at the end of the string, or the first invalid character.
240 Unless C<PERL_SCAN_SILENT_ILLDIGIT> is set in I<*flags>, encountering an
241 invalid character will also trigger a warning.
242 On return I<*len> is set to the length of the scanned string,
243 and I<*flags> gives output flags.
245 If the value is <= UV_MAX it is returned as a UV, the output flags are clear,
246 and nothing is written to I<*result>. If the value is > UV_MAX C<grok_hex>
247 returns UV_MAX, sets C<PERL_SCAN_GREATER_THAN_UV_MAX> in the output flags,
248 and writes the value to I<*result> (or the value is discarded if I<result>
251 The hex number may optionally be prefixed with "0x" or "x" unless
252 C<PERL_SCAN_DISALLOW_PREFIX> is set in I<*flags> on entry. If
253 C<PERL_SCAN_ALLOW_UNDERSCORES> is set in I<*flags> then the hex
254 number may use '_' characters to separate digits.
258 Not documented yet because experimental is C<PERL_SCAN_SILENT_NON_PORTABLE
259 which suppresses any message for non-portable numbers that are still valid
264 Perl_grok_hex(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result)
267 const char *s = start;
271 const UV max_div_16 = UV_MAX / 16;
272 const bool allow_underscores = cBOOL(*flags & PERL_SCAN_ALLOW_UNDERSCORES);
273 bool overflowed = FALSE;
275 PERL_ARGS_ASSERT_GROK_HEX;
277 if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) {
278 /* strip off leading x or 0x.
279 for compatibility silently suffer "x" and "0x" as valid hex numbers.
282 if (s[0] == 'x' || s[0] == 'X') {
286 else if (len >= 2 && s[0] == '0' && (s[1] == 'x' || s[1] == 'X')) {
293 for (; len-- && *s; s++) {
295 /* Write it in this wonky order with a goto to attempt to get the
296 compiler to make the common case integer-only loop pretty tight.
297 With gcc seems to be much straighter code than old scan_hex. */
300 if (value <= max_div_16) {
301 value = (value << 4) | XDIGIT_VALUE(*s);
304 /* Bah. We're just overflowed. */
305 /* diag_listed_as: Integer overflow in %s number */
306 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
307 "Integer overflow in hexadecimal number");
309 value_nv = (NV) value;
312 /* If an NV has not enough bits in its mantissa to
313 * represent a UV this summing of small low-order numbers
314 * is a waste of time (because the NV cannot preserve
315 * the low-order bits anyway): we could just remember when
316 * did we overflow and in the end just multiply value_nv by the
317 * right amount of 16-tuples. */
318 value_nv += (NV) XDIGIT_VALUE(*s);
321 if (*s == '_' && len && allow_underscores && s[1]
328 if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT))
329 Perl_ck_warner(aTHX_ packWARN(WARN_DIGIT),
330 "Illegal hexadecimal digit '%c' ignored", *s);
334 if ( ( overflowed && value_nv > 4294967295.0)
336 || (!overflowed && value > 0xffffffff
337 && ! (*flags & PERL_SCAN_SILENT_NON_PORTABLE))
340 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
341 "Hexadecimal number > 0xffffffff non-portable");
348 *flags = PERL_SCAN_GREATER_THAN_UV_MAX;
357 converts a string representing an octal number to numeric form.
359 On entry I<start> and I<*len> give the string to scan, I<*flags> gives
360 conversion flags, and I<result> should be NULL or a pointer to an NV.
361 The scan stops at the end of the string, or the first invalid character.
362 Unless C<PERL_SCAN_SILENT_ILLDIGIT> is set in I<*flags>, encountering an
363 8 or 9 will also trigger a warning.
364 On return I<*len> is set to the length of the scanned string,
365 and I<*flags> gives output flags.
367 If the value is <= UV_MAX it is returned as a UV, the output flags are clear,
368 and nothing is written to I<*result>. If the value is > UV_MAX C<grok_oct>
369 returns UV_MAX, sets C<PERL_SCAN_GREATER_THAN_UV_MAX> in the output flags,
370 and writes the value to I<*result> (or the value is discarded if I<result>
373 If C<PERL_SCAN_ALLOW_UNDERSCORES> is set in I<*flags> then the octal
374 number may use '_' characters to separate digits.
378 Not documented yet because experimental is C<PERL_SCAN_SILENT_NON_PORTABLE>
379 which suppresses any message for non-portable numbers, but which are valid
384 Perl_grok_oct(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result)
386 const char *s = start;
390 const UV max_div_8 = UV_MAX / 8;
391 const bool allow_underscores = cBOOL(*flags & PERL_SCAN_ALLOW_UNDERSCORES);
392 bool overflowed = FALSE;
394 PERL_ARGS_ASSERT_GROK_OCT;
396 for (; len-- && *s; s++) {
398 /* Write it in this wonky order with a goto to attempt to get the
399 compiler to make the common case integer-only loop pretty tight.
403 if (value <= max_div_8) {
404 value = (value << 3) | OCTAL_VALUE(*s);
407 /* Bah. We're just overflowed. */
408 /* diag_listed_as: Integer overflow in %s number */
409 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
410 "Integer overflow in octal number");
412 value_nv = (NV) value;
415 /* If an NV has not enough bits in its mantissa to
416 * represent a UV this summing of small low-order numbers
417 * is a waste of time (because the NV cannot preserve
418 * the low-order bits anyway): we could just remember when
419 * did we overflow and in the end just multiply value_nv by the
420 * right amount of 8-tuples. */
421 value_nv += (NV) OCTAL_VALUE(*s);
424 if (*s == '_' && len && allow_underscores && isOCTAL(s[1])) {
429 /* Allow \octal to work the DWIM way (that is, stop scanning
430 * as soon as non-octal characters are seen, complain only if
431 * someone seems to want to use the digits eight and nine. Since we
432 * know it is not octal, then if isDIGIT, must be an 8 or 9). */
434 if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT))
435 Perl_ck_warner(aTHX_ packWARN(WARN_DIGIT),
436 "Illegal octal digit '%c' ignored", *s);
441 if ( ( overflowed && value_nv > 4294967295.0)
443 || (!overflowed && value > 0xffffffff
444 && ! (*flags & PERL_SCAN_SILENT_NON_PORTABLE))
447 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
448 "Octal number > 037777777777 non-portable");
455 *flags = PERL_SCAN_GREATER_THAN_UV_MAX;
464 For backwards compatibility. Use C<grok_bin> instead.
468 For backwards compatibility. Use C<grok_hex> instead.
472 For backwards compatibility. Use C<grok_oct> instead.
478 Perl_scan_bin(pTHX_ const char *start, STRLEN len, STRLEN *retlen)
481 I32 flags = *retlen ? PERL_SCAN_ALLOW_UNDERSCORES : 0;
482 const UV ruv = grok_bin (start, &len, &flags, &rnv);
484 PERL_ARGS_ASSERT_SCAN_BIN;
487 return (flags & PERL_SCAN_GREATER_THAN_UV_MAX) ? rnv : (NV)ruv;
491 Perl_scan_oct(pTHX_ const char *start, STRLEN len, STRLEN *retlen)
494 I32 flags = *retlen ? PERL_SCAN_ALLOW_UNDERSCORES : 0;
495 const UV ruv = grok_oct (start, &len, &flags, &rnv);
497 PERL_ARGS_ASSERT_SCAN_OCT;
500 return (flags & PERL_SCAN_GREATER_THAN_UV_MAX) ? rnv : (NV)ruv;
504 Perl_scan_hex(pTHX_ const char *start, STRLEN len, STRLEN *retlen)
507 I32 flags = *retlen ? PERL_SCAN_ALLOW_UNDERSCORES : 0;
508 const UV ruv = grok_hex (start, &len, &flags, &rnv);
510 PERL_ARGS_ASSERT_SCAN_HEX;
513 return (flags & PERL_SCAN_GREATER_THAN_UV_MAX) ? rnv : (NV)ruv;
517 =for apidoc grok_numeric_radix
519 Scan and skip for a numeric decimal separator (radix).
524 Perl_grok_numeric_radix(pTHX_ const char **sp, const char *send)
526 #ifdef USE_LOCALE_NUMERIC
529 PERL_ARGS_ASSERT_GROK_NUMERIC_RADIX;
531 if (PL_numeric_radix_sv && IN_SOME_LOCALE_FORM) {
533 const char * const radix = SvPV(PL_numeric_radix_sv, len);
534 if (*sp + len <= send && memEQ(*sp, radix, len)) {
539 /* always try "." if numeric radix didn't match because
540 * we may have data from different locales mixed */
543 PERL_ARGS_ASSERT_GROK_NUMERIC_RADIX;
545 if (*sp < send && **sp == '.') {
553 =for apidoc grok_number
555 Recognise (or not) a number. The type of the number is returned
556 (0 if unrecognised), otherwise it is a bit-ORed combination of
557 IS_NUMBER_IN_UV, IS_NUMBER_GREATER_THAN_UV_MAX, IS_NUMBER_NOT_INT,
558 IS_NUMBER_NEG, IS_NUMBER_INFINITY, IS_NUMBER_NAN (defined in perl.h).
560 If the value of the number can fit in a UV, it is returned in the *valuep
561 IS_NUMBER_IN_UV will be set to indicate that *valuep is valid, IS_NUMBER_IN_UV
562 will never be set unless *valuep is valid, but *valuep may have been assigned
563 to during processing even though IS_NUMBER_IN_UV is not set on return.
564 If valuep is NULL, IS_NUMBER_IN_UV will be set for the same cases as when
565 valuep is non-NULL, but no actual assignment (or SEGV) will occur.
567 IS_NUMBER_NOT_INT will be set with IS_NUMBER_IN_UV if trailing decimals were
568 seen (in which case *valuep gives the true value truncated to an integer), and
569 IS_NUMBER_NEG if the number is negative (in which case *valuep holds the
570 absolute value). IS_NUMBER_IN_UV is not set if e notation was used or the
571 number is larger than a UV.
576 Perl_grok_number(pTHX_ const char *pv, STRLEN len, UV *valuep)
579 const char * const send = pv + len;
580 const UV max_div_10 = UV_MAX / 10;
581 const char max_mod_10 = UV_MAX % 10;
586 PERL_ARGS_ASSERT_GROK_NUMBER;
588 while (s < send && isSPACE(*s))
592 } else if (*s == '-') {
594 numtype = IS_NUMBER_NEG;
602 /* next must be digit or the radix separator or beginning of infinity */
604 /* UVs are at least 32 bits, so the first 9 decimal digits cannot
607 /* This construction seems to be more optimiser friendly.
608 (without it gcc does the isDIGIT test and the *s - '0' separately)
609 With it gcc on arm is managing 6 instructions (6 cycles) per digit.
610 In theory the optimiser could deduce how far to unroll the loop
611 before checking for overflow. */
613 int digit = *s - '0';
614 if (digit >= 0 && digit <= 9) {
615 value = value * 10 + digit;
618 if (digit >= 0 && digit <= 9) {
619 value = value * 10 + digit;
622 if (digit >= 0 && digit <= 9) {
623 value = value * 10 + digit;
626 if (digit >= 0 && digit <= 9) {
627 value = value * 10 + digit;
630 if (digit >= 0 && digit <= 9) {
631 value = value * 10 + digit;
634 if (digit >= 0 && digit <= 9) {
635 value = value * 10 + digit;
638 if (digit >= 0 && digit <= 9) {
639 value = value * 10 + digit;
642 if (digit >= 0 && digit <= 9) {
643 value = value * 10 + digit;
645 /* Now got 9 digits, so need to check
646 each time for overflow. */
648 while (digit >= 0 && digit <= 9
649 && (value < max_div_10
650 || (value == max_div_10
651 && digit <= max_mod_10))) {
652 value = value * 10 + digit;
658 if (digit >= 0 && digit <= 9
661 skip the remaining digits, don't
662 worry about setting *valuep. */
665 } while (s < send && isDIGIT(*s));
667 IS_NUMBER_GREATER_THAN_UV_MAX;
687 numtype |= IS_NUMBER_IN_UV;
692 if (GROK_NUMERIC_RADIX(&s, send)) {
693 numtype |= IS_NUMBER_NOT_INT;
694 while (s < send && isDIGIT(*s)) /* optional digits after the radix */
698 else if (GROK_NUMERIC_RADIX(&s, send)) {
699 numtype |= IS_NUMBER_NOT_INT | IS_NUMBER_IN_UV; /* valuep assigned below */
700 /* no digits before the radix means we need digits after it */
701 if (s < send && isDIGIT(*s)) {
704 } while (s < send && isDIGIT(*s));
706 /* integer approximation is valid - it's 0. */
712 } else if (*s == 'I' || *s == 'i') {
713 s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
714 s++; if (s == send || (*s != 'F' && *s != 'f')) return 0;
715 s++; if (s < send && (*s == 'I' || *s == 'i')) {
716 s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
717 s++; if (s == send || (*s != 'I' && *s != 'i')) return 0;
718 s++; if (s == send || (*s != 'T' && *s != 't')) return 0;
719 s++; if (s == send || (*s != 'Y' && *s != 'y')) return 0;
723 } else if (*s == 'N' || *s == 'n') {
724 /* XXX TODO: There are signaling NaNs and quiet NaNs. */
725 s++; if (s == send || (*s != 'A' && *s != 'a')) return 0;
726 s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
733 numtype &= IS_NUMBER_NEG; /* Keep track of sign */
734 numtype |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT;
736 numtype &= IS_NUMBER_NEG; /* Keep track of sign */
737 numtype |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT;
738 } else if (s < send) {
739 /* we can have an optional exponent part */
740 if (*s == 'e' || *s == 'E') {
741 /* The only flag we keep is sign. Blow away any "it's UV" */
742 numtype &= IS_NUMBER_NEG;
743 numtype |= IS_NUMBER_NOT_INT;
745 if (s < send && (*s == '-' || *s == '+'))
747 if (s < send && isDIGIT(*s)) {
750 } while (s < send && isDIGIT(*s));
756 while (s < send && isSPACE(*s))
760 if (len == 10 && memEQ(pv, "0 but true", 10)) {
763 return IS_NUMBER_IN_UV;
769 S_mulexp10(NV value, I32 exponent)
781 /* On OpenVMS VAX we by default use the D_FLOAT double format,
782 * and that format does not have *easy* capabilities [1] for
783 * overflowing doubles 'silently' as IEEE fp does. We also need
784 * to support G_FLOAT on both VAX and Alpha, and though the exponent
785 * range is much larger than D_FLOAT it still doesn't do silent
786 * overflow. Therefore we need to detect early whether we would
787 * overflow (this is the behaviour of the native string-to-float
788 * conversion routines, and therefore of native applications, too).
790 * [1] Trying to establish a condition handler to trap floating point
791 * exceptions is not a good idea. */
793 /* In UNICOS and in certain Cray models (such as T90) there is no
794 * IEEE fp, and no way at all from C to catch fp overflows gracefully.
795 * There is something you can do if you are willing to use some
796 * inline assembler: the instruction is called DFI-- but that will
797 * disable *all* floating point interrupts, a little bit too large
798 * a hammer. Therefore we need to catch potential overflows before
801 #if ((defined(VMS) && !defined(_IEEE_FP)) || defined(_UNICOS)) && defined(NV_MAX_10_EXP)
803 const NV exp_v = log10(value);
804 if (exponent >= NV_MAX_10_EXP || exponent + exp_v >= NV_MAX_10_EXP)
807 if (-(exponent + exp_v) >= NV_MAX_10_EXP)
809 while (-exponent >= NV_MAX_10_EXP) {
810 /* combination does not overflow, but 10^(-exponent) does */
820 exponent = -exponent;
822 /* for something like 1234 x 10^-309, the action of calculating
823 * the intermediate value 10^309 then returning 1234 / (10^309)
824 * will fail, since 10^309 becomes infinity. In this case try to
825 * refactor it as 123 / (10^308) etc.
827 while (value && exponent > NV_MAX_10_EXP) {
833 for (bit = 1; exponent; bit <<= 1) {
834 if (exponent & bit) {
837 /* Floating point exceptions are supposed to be turned off,
838 * but if we're obviously done, don't risk another iteration.
840 if (exponent == 0) break;
844 return negative ? value / result : value * result;
848 Perl_my_atof(pTHX_ const char* s)
851 #ifdef USE_LOCALE_NUMERIC
854 PERL_ARGS_ASSERT_MY_ATOF;
857 DECLARE_STORE_LC_NUMERIC_SET_TO_NEEDED();
858 if (PL_numeric_local && PL_numeric_radix_sv && IN_SOME_LOCALE_FORM) {
859 const char *standard = NULL, *local = NULL;
860 bool use_standard_radix;
862 /* Look through the string for the first thing that looks like a
863 * decimal point: either the value in the current locale or the
864 * standard fallback of '.'. The one which appears earliest in the
865 * input string is the one that we should have atof look for. Note
866 * that we have to determine this beforehand because on some
867 * systems, Perl_atof2 is just a wrapper around the system's atof.
869 standard = strchr(s, '.');
870 local = strstr(s, SvPV_nolen(PL_numeric_radix_sv));
872 use_standard_radix = standard && (!local || standard < local);
874 if (use_standard_radix)
875 SET_NUMERIC_STANDARD();
879 if (use_standard_radix)
884 RESTORE_LC_NUMERIC();
893 Perl_my_atof2(pTHX_ const char* orig, NV* value)
895 NV result[3] = {0.0, 0.0, 0.0};
896 const char* s = orig;
898 UV accumulator[2] = {0,0}; /* before/after dp */
900 const char* send = s + strlen(orig) - 1;
902 I32 exp_adjust[2] = {0,0};
903 I32 exp_acc[2] = {-1, -1};
904 /* the current exponent adjust for the accumulators */
909 I32 sig_digits = 0; /* noof significant digits seen so far */
911 PERL_ARGS_ASSERT_MY_ATOF2;
913 /* There is no point in processing more significant digits
914 * than the NV can hold. Note that NV_DIG is a lower-bound value,
915 * while we need an upper-bound value. We add 2 to account for this;
916 * since it will have been conservative on both the first and last digit.
917 * For example a 32-bit mantissa with an exponent of 4 would have
918 * exact values in the set
926 * where for the purposes of calculating NV_DIG we would have to discount
927 * both the first and last digit, since neither can hold all values from
928 * 0..9; but for calculating the value we must examine those two digits.
930 #ifdef MAX_SIG_DIG_PLUS
931 /* It is not necessarily the case that adding 2 to NV_DIG gets all the
932 possible digits in a NV, especially if NVs are not IEEE compliant
933 (e.g., long doubles on IRIX) - Allen <allens@cpan.org> */
934 # define MAX_SIG_DIGITS (NV_DIG+MAX_SIG_DIG_PLUS)
936 # define MAX_SIG_DIGITS (NV_DIG+2)
939 /* the max number we can accumulate in a UV, and still safely do 10*N+9 */
940 #define MAX_ACCUMULATE ( (UV) ((UV_MAX - 9)/10))
942 /* leading whitespace */
955 /* punt to strtod for NaN/Inf; if no support for it there, tough luck */
958 if (*s == 'n' || *s == 'N' || *s == 'i' || *s == 'I') {
959 const char *p = negative ? s - 1 : s;
962 rslt = strtod(p, &endp);
970 /* we accumulate digits into an integer; when this becomes too
971 * large, we add the total to NV and start again */
981 /* don't start counting until we see the first significant
982 * digit, eg the 5 in 0.00005... */
983 if (!sig_digits && digit == 0)
986 if (++sig_digits > MAX_SIG_DIGITS) {
987 /* limits of precision reached */
989 ++accumulator[seen_dp];
990 } else if (digit == 5) {
991 if (old_digit % 2) { /* round to even - Allen */
992 ++accumulator[seen_dp];
1000 /* skip remaining digits */
1001 while (isDIGIT(*s)) {
1007 /* warn of loss of precision? */
1010 if (accumulator[seen_dp] > MAX_ACCUMULATE) {
1011 /* add accumulator to result and start again */
1012 result[seen_dp] = S_mulexp10(result[seen_dp],
1014 + (NV)accumulator[seen_dp];
1015 accumulator[seen_dp] = 0;
1016 exp_acc[seen_dp] = 0;
1018 accumulator[seen_dp] = accumulator[seen_dp] * 10 + digit;
1022 else if (!seen_dp && GROK_NUMERIC_RADIX(&s, send)) {
1024 if (sig_digits > MAX_SIG_DIGITS) {
1027 } while (isDIGIT(*s));
1036 result[0] = S_mulexp10(result[0], exp_acc[0]) + (NV)accumulator[0];
1038 result[1] = S_mulexp10(result[1], exp_acc[1]) + (NV)accumulator[1];
1041 if (seen_digit && (*s == 'e' || *s == 'E')) {
1042 bool expnegative = 0;
1053 exponent = exponent * 10 + (*s++ - '0');
1055 exponent = -exponent;
1060 /* now apply the exponent */
1063 result[2] = S_mulexp10(result[0],exponent+exp_adjust[0])
1064 + S_mulexp10(result[1],exponent-exp_adjust[1]);
1066 result[2] = S_mulexp10(result[0],exponent+exp_adjust[0]);
1069 /* now apply the sign */
1071 result[2] = -result[2];
1072 #endif /* USE_PERL_ATOF */
1077 #if ! defined(HAS_MODFL) && defined(HAS_AINTL) && defined(HAS_COPYSIGNL)
1079 Perl_my_modfl(long double x, long double *ip)
1082 return (x == *ip ? copysignl(0.0L, x) : x - *ip);
1086 #if ! defined(HAS_FREXPL) && defined(HAS_ILOGBL) && defined(HAS_SCALBNL)
1088 Perl_my_frexpl(long double x, int *e) {
1089 *e = x == 0.0L ? 0 : ilogbl(x) + 1;
1090 return (scalbnl(x, -*e));
1095 =for apidoc Perl_signbit
1097 Return a non-zero integer if the sign bit on an NV is set, and 0 if
1100 If Configure detects this system has a signbit() that will work with
1101 our NVs, then we just use it via the #define in perl.h. Otherwise,
1102 fall back on this implementation. As a first pass, this gets everything
1103 right except -0.0. Alas, catching -0.0 is the main use for this function,
1104 so this is not too helpful yet. Still, at least we have the scaffolding
1105 in place to support other systems, should that prove useful.
1108 Configure notes: This function is called 'Perl_signbit' instead of a
1109 plain 'signbit' because it is easy to imagine a system having a signbit()
1110 function or macro that doesn't happen to work with our particular choice
1111 of NVs. We shouldn't just re-#define signbit as Perl_signbit and expect
1112 the standard system headers to be happy. Also, this is a no-context
1113 function (no pTHX_) because Perl_signbit() is usually re-#defined in
1114 perl.h as a simple macro call to the system's signbit().
1115 Users should just always call Perl_signbit().
1119 #if !defined(HAS_SIGNBIT)
1121 Perl_signbit(NV x) {
1122 return (x < 0.0) ? 1 : 0;
1128 * c-indentation-style: bsd
1130 * indent-tabs-mode: nil
1133 * ex: set ts=8 sts=4 sw=4 et: