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 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
184 "Integer overflow in binary number");
186 value_nv = (NV) value;
189 /* If an NV has not enough bits in its mantissa to
190 * represent a UV this summing of small low-order numbers
191 * is a waste of time (because the NV cannot preserve
192 * the low-order bits anyway): we could just remember when
193 * did we overflow and in the end just multiply value_nv by the
195 value_nv += (NV)(bit - '0');
198 if (bit == '_' && len && allow_underscores && (bit = s[1])
199 && (bit == '0' || bit == '1'))
205 if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT))
206 Perl_ck_warner(aTHX_ packWARN(WARN_DIGIT),
207 "Illegal binary digit '%c' ignored", *s);
211 if ( ( overflowed && value_nv > 4294967295.0)
213 || (!overflowed && value > 0xffffffff
214 && ! (*flags & PERL_SCAN_SILENT_NON_PORTABLE))
217 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
218 "Binary number > 0b11111111111111111111111111111111 non-portable");
225 *flags = PERL_SCAN_GREATER_THAN_UV_MAX;
234 converts a string representing a hex number to numeric form.
236 On entry I<start> and I<*len> give the string to scan, I<*flags> gives
237 conversion flags, and I<result> should be NULL or a pointer to an NV.
238 The scan stops at the end of the string, or the first invalid character.
239 Unless C<PERL_SCAN_SILENT_ILLDIGIT> is set in I<*flags>, encountering an
240 invalid character will also trigger a warning.
241 On return I<*len> is set to the length of the scanned string,
242 and I<*flags> gives output flags.
244 If the value is <= UV_MAX it is returned as a UV, the output flags are clear,
245 and nothing is written to I<*result>. If the value is > UV_MAX C<grok_hex>
246 returns UV_MAX, sets C<PERL_SCAN_GREATER_THAN_UV_MAX> in the output flags,
247 and writes the value to I<*result> (or the value is discarded if I<result>
250 The hex number may optionally be prefixed with "0x" or "x" unless
251 C<PERL_SCAN_DISALLOW_PREFIX> is set in I<*flags> on entry. If
252 C<PERL_SCAN_ALLOW_UNDERSCORES> is set in I<*flags> then the hex
253 number may use '_' characters to separate digits.
257 Not documented yet because experimental is C<PERL_SCAN_SILENT_NON_PORTABLE
258 which suppresses any message for non-portable numbers that are still valid
263 Perl_grok_hex(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result)
266 const char *s = start;
270 const UV max_div_16 = UV_MAX / 16;
271 const bool allow_underscores = cBOOL(*flags & PERL_SCAN_ALLOW_UNDERSCORES);
272 bool overflowed = FALSE;
274 PERL_ARGS_ASSERT_GROK_HEX;
276 if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) {
277 /* strip off leading x or 0x.
278 for compatibility silently suffer "x" and "0x" as valid hex numbers.
281 if (s[0] == 'x' || s[0] == 'X') {
285 else if (len >= 2 && s[0] == '0' && (s[1] == 'x' || s[1] == 'X')) {
292 for (; len-- && *s; s++) {
293 const char *hexdigit = strchr(PL_hexdigit, *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) | ((hexdigit - PL_hexdigit) & 15);
304 /* Bah. We're just overflowed. */
305 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
306 "Integer overflow in hexadecimal number");
308 value_nv = (NV) value;
311 /* If an NV has not enough bits in its mantissa to
312 * represent a UV this summing of small low-order numbers
313 * is a waste of time (because the NV cannot preserve
314 * the low-order bits anyway): we could just remember when
315 * did we overflow and in the end just multiply value_nv by the
316 * right amount of 16-tuples. */
317 value_nv += (NV)((hexdigit - PL_hexdigit) & 15);
320 if (*s == '_' && len && allow_underscores && s[1]
321 && (hexdigit = strchr(PL_hexdigit, s[1])))
327 if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT))
328 Perl_ck_warner(aTHX_ packWARN(WARN_DIGIT),
329 "Illegal hexadecimal digit '%c' ignored", *s);
333 if ( ( overflowed && value_nv > 4294967295.0)
335 || (!overflowed && value > 0xffffffff
336 && ! (*flags & PERL_SCAN_SILENT_NON_PORTABLE))
339 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
340 "Hexadecimal number > 0xffffffff non-portable");
347 *flags = PERL_SCAN_GREATER_THAN_UV_MAX;
356 converts a string representing an octal number to numeric form.
358 On entry I<start> and I<*len> give the string to scan, I<*flags> gives
359 conversion flags, and I<result> should be NULL or a pointer to an NV.
360 The scan stops at the end of the string, or the first invalid character.
361 Unless C<PERL_SCAN_SILENT_ILLDIGIT> is set in I<*flags>, encountering an
362 8 or 9 will also trigger a warning.
363 On return I<*len> is set to the length of the scanned string,
364 and I<*flags> gives output flags.
366 If the value is <= UV_MAX it is returned as a UV, the output flags are clear,
367 and nothing is written to I<*result>. If the value is > UV_MAX C<grok_oct>
368 returns UV_MAX, sets C<PERL_SCAN_GREATER_THAN_UV_MAX> in the output flags,
369 and writes the value to I<*result> (or the value is discarded if I<result>
372 If C<PERL_SCAN_ALLOW_UNDERSCORES> is set in I<*flags> then the octal
373 number may use '_' characters to separate digits.
377 Not documented yet because experimental is C<PERL_SCAN_SILENT_NON_PORTABLE
378 which suppresses any message for non-portable numbers that are still valid
383 Perl_grok_oct(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result)
385 const char *s = start;
389 const UV max_div_8 = UV_MAX / 8;
390 const bool allow_underscores = cBOOL(*flags & PERL_SCAN_ALLOW_UNDERSCORES);
391 bool overflowed = FALSE;
393 PERL_ARGS_ASSERT_GROK_OCT;
395 for (; len-- && *s; s++) {
396 /* gcc 2.95 optimiser not smart enough to figure that this subtraction
397 out front allows slicker code. */
398 int digit = *s - '0';
399 if (digit >= 0 && digit <= 7) {
400 /* Write it in this wonky order with a goto to attempt to get the
401 compiler to make the common case integer-only loop pretty tight.
405 if (value <= max_div_8) {
406 value = (value << 3) | digit;
409 /* Bah. We're just overflowed. */
410 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
411 "Integer overflow in octal number");
413 value_nv = (NV) value;
416 /* If an NV has not enough bits in its mantissa to
417 * represent a UV this summing of small low-order numbers
418 * is a waste of time (because the NV cannot preserve
419 * the low-order bits anyway): we could just remember when
420 * did we overflow and in the end just multiply value_nv by the
421 * right amount of 8-tuples. */
422 value_nv += (NV)digit;
425 if (digit == ('_' - '0') && len && allow_underscores
426 && (digit = s[1] - '0') && (digit >= 0 && digit <= 7))
432 /* Allow \octal to work the DWIM way (that is, stop scanning
433 * as soon as non-octal characters are seen, complain only if
434 * someone seems to want to use the digits eight and nine). */
435 if (digit == 8 || digit == 9) {
436 if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT))
437 Perl_ck_warner(aTHX_ packWARN(WARN_DIGIT),
438 "Illegal octal digit '%c' ignored", *s);
443 if ( ( overflowed && value_nv > 4294967295.0)
445 || (!overflowed && value > 0xffffffff
446 && ! (*flags & PERL_SCAN_SILENT_NON_PORTABLE))
449 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
450 "Octal number > 037777777777 non-portable");
457 *flags = PERL_SCAN_GREATER_THAN_UV_MAX;
466 For backwards compatibility. Use C<grok_bin> instead.
470 For backwards compatibility. Use C<grok_hex> instead.
474 For backwards compatibility. Use C<grok_oct> instead.
480 Perl_scan_bin(pTHX_ const char *start, STRLEN len, STRLEN *retlen)
483 I32 flags = *retlen ? PERL_SCAN_ALLOW_UNDERSCORES : 0;
484 const UV ruv = grok_bin (start, &len, &flags, &rnv);
486 PERL_ARGS_ASSERT_SCAN_BIN;
489 return (flags & PERL_SCAN_GREATER_THAN_UV_MAX) ? rnv : (NV)ruv;
493 Perl_scan_oct(pTHX_ const char *start, STRLEN len, STRLEN *retlen)
496 I32 flags = *retlen ? PERL_SCAN_ALLOW_UNDERSCORES : 0;
497 const UV ruv = grok_oct (start, &len, &flags, &rnv);
499 PERL_ARGS_ASSERT_SCAN_OCT;
502 return (flags & PERL_SCAN_GREATER_THAN_UV_MAX) ? rnv : (NV)ruv;
506 Perl_scan_hex(pTHX_ const char *start, STRLEN len, STRLEN *retlen)
509 I32 flags = *retlen ? PERL_SCAN_ALLOW_UNDERSCORES : 0;
510 const UV ruv = grok_hex (start, &len, &flags, &rnv);
512 PERL_ARGS_ASSERT_SCAN_HEX;
515 return (flags & PERL_SCAN_GREATER_THAN_UV_MAX) ? rnv : (NV)ruv;
519 =for apidoc grok_numeric_radix
521 Scan and skip for a numeric decimal separator (radix).
526 Perl_grok_numeric_radix(pTHX_ const char **sp, const char *send)
528 #ifdef USE_LOCALE_NUMERIC
531 PERL_ARGS_ASSERT_GROK_NUMERIC_RADIX;
533 if (PL_numeric_radix_sv && IN_LOCALE) {
535 const char * const radix = SvPV(PL_numeric_radix_sv, len);
536 if (*sp + len <= send && memEQ(*sp, radix, len)) {
541 /* always try "." if numeric radix didn't match because
542 * we may have data from different locales mixed */
545 PERL_ARGS_ASSERT_GROK_NUMERIC_RADIX;
547 if (*sp < send && **sp == '.') {
555 =for apidoc grok_number
557 Recognise (or not) a number. The type of the number is returned
558 (0 if unrecognised), otherwise it is a bit-ORed combination of
559 IS_NUMBER_IN_UV, IS_NUMBER_GREATER_THAN_UV_MAX, IS_NUMBER_NOT_INT,
560 IS_NUMBER_NEG, IS_NUMBER_INFINITY, IS_NUMBER_NAN (defined in perl.h).
562 If the value of the number can fit an in UV, it is returned in the *valuep
563 IS_NUMBER_IN_UV will be set to indicate that *valuep is valid, IS_NUMBER_IN_UV
564 will never be set unless *valuep is valid, but *valuep may have been assigned
565 to during processing even though IS_NUMBER_IN_UV is not set on return.
566 If valuep is NULL, IS_NUMBER_IN_UV will be set for the same cases as when
567 valuep is non-NULL, but no actual assignment (or SEGV) will occur.
569 IS_NUMBER_NOT_INT will be set with IS_NUMBER_IN_UV if trailing decimals were
570 seen (in which case *valuep gives the true value truncated to an integer), and
571 IS_NUMBER_NEG if the number is negative (in which case *valuep holds the
572 absolute value). IS_NUMBER_IN_UV is not set if e notation was used or the
573 number is larger than a UV.
578 Perl_grok_number(pTHX_ const char *pv, STRLEN len, UV *valuep)
581 const char * const send = pv + len;
582 const UV max_div_10 = UV_MAX / 10;
583 const char max_mod_10 = UV_MAX % 10;
588 PERL_ARGS_ASSERT_GROK_NUMBER;
590 while (s < send && isSPACE(*s))
594 } else if (*s == '-') {
596 numtype = IS_NUMBER_NEG;
604 /* next must be digit or the radix separator or beginning of infinity */
606 /* UVs are at least 32 bits, so the first 9 decimal digits cannot
609 /* This construction seems to be more optimiser friendly.
610 (without it gcc does the isDIGIT test and the *s - '0' separately)
611 With it gcc on arm is managing 6 instructions (6 cycles) per digit.
612 In theory the optimiser could deduce how far to unroll the loop
613 before checking for overflow. */
615 int digit = *s - '0';
616 if (digit >= 0 && digit <= 9) {
617 value = value * 10 + digit;
620 if (digit >= 0 && digit <= 9) {
621 value = value * 10 + digit;
624 if (digit >= 0 && digit <= 9) {
625 value = value * 10 + digit;
628 if (digit >= 0 && digit <= 9) {
629 value = value * 10 + digit;
632 if (digit >= 0 && digit <= 9) {
633 value = value * 10 + digit;
636 if (digit >= 0 && digit <= 9) {
637 value = value * 10 + digit;
640 if (digit >= 0 && digit <= 9) {
641 value = value * 10 + digit;
644 if (digit >= 0 && digit <= 9) {
645 value = value * 10 + digit;
647 /* Now got 9 digits, so need to check
648 each time for overflow. */
650 while (digit >= 0 && digit <= 9
651 && (value < max_div_10
652 || (value == max_div_10
653 && digit <= max_mod_10))) {
654 value = value * 10 + digit;
660 if (digit >= 0 && digit <= 9
663 skip the remaining digits, don't
664 worry about setting *valuep. */
667 } while (s < send && isDIGIT(*s));
669 IS_NUMBER_GREATER_THAN_UV_MAX;
689 numtype |= IS_NUMBER_IN_UV;
694 if (GROK_NUMERIC_RADIX(&s, send)) {
695 numtype |= IS_NUMBER_NOT_INT;
696 while (s < send && isDIGIT(*s)) /* optional digits after the radix */
700 else if (GROK_NUMERIC_RADIX(&s, send)) {
701 numtype |= IS_NUMBER_NOT_INT | IS_NUMBER_IN_UV; /* valuep assigned below */
702 /* no digits before the radix means we need digits after it */
703 if (s < send && isDIGIT(*s)) {
706 } while (s < send && isDIGIT(*s));
708 /* integer approximation is valid - it's 0. */
714 } else if (*s == 'I' || *s == 'i') {
715 s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
716 s++; if (s == send || (*s != 'F' && *s != 'f')) return 0;
717 s++; if (s < send && (*s == 'I' || *s == 'i')) {
718 s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
719 s++; if (s == send || (*s != 'I' && *s != 'i')) return 0;
720 s++; if (s == send || (*s != 'T' && *s != 't')) return 0;
721 s++; if (s == send || (*s != 'Y' && *s != 'y')) return 0;
725 } else if (*s == 'N' || *s == 'n') {
726 /* XXX TODO: There are signaling NaNs and quiet NaNs. */
727 s++; if (s == send || (*s != 'A' && *s != 'a')) return 0;
728 s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
735 numtype &= IS_NUMBER_NEG; /* Keep track of sign */
736 numtype |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT;
738 numtype &= IS_NUMBER_NEG; /* Keep track of sign */
739 numtype |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT;
740 } else if (s < send) {
741 /* we can have an optional exponent part */
742 if (*s == 'e' || *s == 'E') {
743 /* The only flag we keep is sign. Blow away any "it's UV" */
744 numtype &= IS_NUMBER_NEG;
745 numtype |= IS_NUMBER_NOT_INT;
747 if (s < send && (*s == '-' || *s == '+'))
749 if (s < send && isDIGIT(*s)) {
752 } while (s < send && isDIGIT(*s));
758 while (s < send && isSPACE(*s))
762 if (len == 10 && memEQ(pv, "0 but true", 10)) {
765 return IS_NUMBER_IN_UV;
771 S_mulexp10(NV value, I32 exponent)
783 /* On OpenVMS VAX we by default use the D_FLOAT double format,
784 * and that format does not have *easy* capabilities [1] for
785 * overflowing doubles 'silently' as IEEE fp does. We also need
786 * to support G_FLOAT on both VAX and Alpha, and though the exponent
787 * range is much larger than D_FLOAT it still doesn't do silent
788 * overflow. Therefore we need to detect early whether we would
789 * overflow (this is the behaviour of the native string-to-float
790 * conversion routines, and therefore of native applications, too).
792 * [1] Trying to establish a condition handler to trap floating point
793 * exceptions is not a good idea. */
795 /* In UNICOS and in certain Cray models (such as T90) there is no
796 * IEEE fp, and no way at all from C to catch fp overflows gracefully.
797 * There is something you can do if you are willing to use some
798 * inline assembler: the instruction is called DFI-- but that will
799 * disable *all* floating point interrupts, a little bit too large
800 * a hammer. Therefore we need to catch potential overflows before
803 #if ((defined(VMS) && !defined(__IEEE_FP)) || defined(_UNICOS)) && defined(NV_MAX_10_EXP)
805 const NV exp_v = log10(value);
806 if (exponent >= NV_MAX_10_EXP || exponent + exp_v >= NV_MAX_10_EXP)
809 if (-(exponent + exp_v) >= NV_MAX_10_EXP)
811 while (-exponent >= NV_MAX_10_EXP) {
812 /* combination does not overflow, but 10^(-exponent) does */
822 exponent = -exponent;
824 for (bit = 1; exponent; bit <<= 1) {
825 if (exponent & bit) {
828 /* Floating point exceptions are supposed to be turned off,
829 * but if we're obviously done, don't risk another iteration.
831 if (exponent == 0) break;
835 return negative ? value / result : value * result;
839 Perl_my_atof(pTHX_ const char* s)
842 #ifdef USE_LOCALE_NUMERIC
845 PERL_ARGS_ASSERT_MY_ATOF;
847 if (PL_numeric_local && IN_LOCALE) {
850 /* Scan the number twice; once using locale and once without;
851 * choose the larger result (in absolute value). */
853 SET_NUMERIC_STANDARD();
856 if ((y < 0.0 && y < x) || (y > 0.0 && y > x))
868 Perl_my_atof2(pTHX_ const char* orig, NV* value)
870 NV result[3] = {0.0, 0.0, 0.0};
871 const char* s = orig;
873 UV accumulator[2] = {0,0}; /* before/after dp */
875 const char* send = s + strlen(orig) - 1;
877 I32 exp_adjust[2] = {0,0};
878 I32 exp_acc[2] = {-1, -1};
879 /* the current exponent adjust for the accumulators */
884 I32 sig_digits = 0; /* noof significant digits seen so far */
886 PERL_ARGS_ASSERT_MY_ATOF2;
888 /* There is no point in processing more significant digits
889 * than the NV can hold. Note that NV_DIG is a lower-bound value,
890 * while we need an upper-bound value. We add 2 to account for this;
891 * since it will have been conservative on both the first and last digit.
892 * For example a 32-bit mantissa with an exponent of 4 would have
893 * exact values in the set
901 * where for the purposes of calculating NV_DIG we would have to discount
902 * both the first and last digit, since neither can hold all values from
903 * 0..9; but for calculating the value we must examine those two digits.
905 #ifdef MAX_SIG_DIG_PLUS
906 /* It is not necessarily the case that adding 2 to NV_DIG gets all the
907 possible digits in a NV, especially if NVs are not IEEE compliant
908 (e.g., long doubles on IRIX) - Allen <allens@cpan.org> */
909 # define MAX_SIG_DIGITS (NV_DIG+MAX_SIG_DIG_PLUS)
911 # define MAX_SIG_DIGITS (NV_DIG+2)
914 /* the max number we can accumulate in a UV, and still safely do 10*N+9 */
915 #define MAX_ACCUMULATE ( (UV) ((UV_MAX - 9)/10))
917 /* leading whitespace */
930 /* punt to strtod for NaN/Inf; if no support for it there, tough luck */
933 if (*s == 'n' || *s == 'N' || *s == 'i' || *s == 'I') {
934 const char *p = negative ? s - 1 : s;
937 rslt = strtod(p, &endp);
945 /* we accumulate digits into an integer; when this becomes too
946 * large, we add the total to NV and start again */
956 /* don't start counting until we see the first significant
957 * digit, eg the 5 in 0.00005... */
958 if (!sig_digits && digit == 0)
961 if (++sig_digits > MAX_SIG_DIGITS) {
962 /* limits of precision reached */
964 ++accumulator[seen_dp];
965 } else if (digit == 5) {
966 if (old_digit % 2) { /* round to even - Allen */
967 ++accumulator[seen_dp];
975 /* skip remaining digits */
976 while (isDIGIT(*s)) {
982 /* warn of loss of precision? */
985 if (accumulator[seen_dp] > MAX_ACCUMULATE) {
986 /* add accumulator to result and start again */
987 result[seen_dp] = S_mulexp10(result[seen_dp],
989 + (NV)accumulator[seen_dp];
990 accumulator[seen_dp] = 0;
991 exp_acc[seen_dp] = 0;
993 accumulator[seen_dp] = accumulator[seen_dp] * 10 + digit;
997 else if (!seen_dp && GROK_NUMERIC_RADIX(&s, send)) {
999 if (sig_digits > MAX_SIG_DIGITS) {
1002 } while (isDIGIT(*s));
1011 result[0] = S_mulexp10(result[0], exp_acc[0]) + (NV)accumulator[0];
1013 result[1] = S_mulexp10(result[1], exp_acc[1]) + (NV)accumulator[1];
1016 if (seen_digit && (*s == 'e' || *s == 'E')) {
1017 bool expnegative = 0;
1028 exponent = exponent * 10 + (*s++ - '0');
1030 exponent = -exponent;
1035 /* now apply the exponent */
1038 result[2] = S_mulexp10(result[0],exponent+exp_adjust[0])
1039 + S_mulexp10(result[1],exponent-exp_adjust[1]);
1041 result[2] = S_mulexp10(result[0],exponent+exp_adjust[0]);
1044 /* now apply the sign */
1046 result[2] = -result[2];
1047 #endif /* USE_PERL_ATOF */
1052 #if ! defined(HAS_MODFL) && defined(HAS_AINTL) && defined(HAS_COPYSIGNL)
1054 Perl_my_modfl(long double x, long double *ip)
1057 return (x == *ip ? copysignl(0.0L, x) : x - *ip);
1061 #if ! defined(HAS_FREXPL) && defined(HAS_ILOGBL) && defined(HAS_SCALBNL)
1063 Perl_my_frexpl(long double x, int *e) {
1064 *e = x == 0.0L ? 0 : ilogbl(x) + 1;
1065 return (scalbnl(x, -*e));
1070 =for apidoc Perl_signbit
1072 Return a non-zero integer if the sign bit on an NV is set, and 0 if
1075 If Configure detects this system has a signbit() that will work with
1076 our NVs, then we just use it via the #define in perl.h. Otherwise,
1077 fall back on this implementation. As a first pass, this gets everything
1078 right except -0.0. Alas, catching -0.0 is the main use for this function,
1079 so this is not too helpful yet. Still, at least we have the scaffolding
1080 in place to support other systems, should that prove useful.
1083 Configure notes: This function is called 'Perl_signbit' instead of a
1084 plain 'signbit' because it is easy to imagine a system having a signbit()
1085 function or macro that doesn't happen to work with our particular choice
1086 of NVs. We shouldn't just re-#define signbit as Perl_signbit and expect
1087 the standard system headers to be happy. Also, this is a no-context
1088 function (no pTHX_) because Perl_signbit() is usually re-#defined in
1089 perl.h as a simple macro call to the system's signbit().
1090 Users should just always call Perl_signbit().
1094 #if !defined(HAS_SIGNBIT)
1096 Perl_signbit(NV x) {
1097 return (x < 0.0) ? 1 : 0;
1103 * c-indentation-style: bsd
1105 * indent-tabs-mode: t
1108 * ex: set ts=8 sts=4 sw=4 noet: