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> 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++) {
294 const char *hexdigit = strchr(PL_hexdigit, *s);
296 /* Write it in this wonky order with a goto to attempt to get the
297 compiler to make the common case integer-only loop pretty tight.
298 With gcc seems to be much straighter code than old scan_hex. */
301 if (value <= max_div_16) {
302 value = (value << 4) | ((hexdigit - PL_hexdigit) & 15);
305 /* Bah. We're just overflowed. */
306 /* diag_listed_as: Integer overflow in %s number */
307 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
308 "Integer overflow in hexadecimal number");
310 value_nv = (NV) value;
313 /* If an NV has not enough bits in its mantissa to
314 * represent a UV this summing of small low-order numbers
315 * is a waste of time (because the NV cannot preserve
316 * the low-order bits anyway): we could just remember when
317 * did we overflow and in the end just multiply value_nv by the
318 * right amount of 16-tuples. */
319 value_nv += (NV)((hexdigit - PL_hexdigit) & 15);
322 if (*s == '_' && len && allow_underscores && s[1]
323 && (hexdigit = strchr(PL_hexdigit, s[1])))
329 if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT))
330 Perl_ck_warner(aTHX_ packWARN(WARN_DIGIT),
331 "Illegal hexadecimal digit '%c' ignored", *s);
335 if ( ( overflowed && value_nv > 4294967295.0)
337 || (!overflowed && value > 0xffffffff
338 && ! (*flags & PERL_SCAN_SILENT_NON_PORTABLE))
341 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
342 "Hexadecimal number > 0xffffffff non-portable");
349 *flags = PERL_SCAN_GREATER_THAN_UV_MAX;
358 converts a string representing an octal number to numeric form.
360 On entry I<start> and I<*len> give the string to scan, I<*flags> gives
361 conversion flags, and I<result> should be NULL or a pointer to an NV.
362 The scan stops at the end of the string, or the first invalid character.
363 Unless C<PERL_SCAN_SILENT_ILLDIGIT> is set in I<*flags>, encountering an
364 8 or 9 will also trigger a warning.
365 On return I<*len> is set to the length of the scanned string,
366 and I<*flags> gives output flags.
368 If the value is <= UV_MAX it is returned as a UV, the output flags are clear,
369 and nothing is written to I<*result>. If the value is > UV_MAX C<grok_oct>
370 returns UV_MAX, sets C<PERL_SCAN_GREATER_THAN_UV_MAX> in the output flags,
371 and writes the value to I<*result> (or the value is discarded if I<result>
374 If C<PERL_SCAN_ALLOW_UNDERSCORES> is set in I<*flags> then the octal
375 number may use '_' characters to separate digits.
379 Not documented yet because experimental is C<PERL_SCAN_SILENT_NON_PORTABLE
380 which suppresses any message for non-portable numbers that are still valid
385 Perl_grok_oct(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result)
387 const char *s = start;
391 const UV max_div_8 = UV_MAX / 8;
392 const bool allow_underscores = cBOOL(*flags & PERL_SCAN_ALLOW_UNDERSCORES);
393 bool overflowed = FALSE;
395 PERL_ARGS_ASSERT_GROK_OCT;
397 for (; len-- && *s; s++) {
398 /* gcc 2.95 optimiser not smart enough to figure that this subtraction
399 out front allows slicker code. */
400 int digit = *s - '0';
401 if (digit >= 0 && digit <= 7) {
402 /* Write it in this wonky order with a goto to attempt to get the
403 compiler to make the common case integer-only loop pretty tight.
407 if (value <= max_div_8) {
408 value = (value << 3) | digit;
411 /* Bah. We're just overflowed. */
412 /* diag_listed_as: Integer overflow in %s number */
413 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
414 "Integer overflow in octal number");
416 value_nv = (NV) value;
419 /* If an NV has not enough bits in its mantissa to
420 * represent a UV this summing of small low-order numbers
421 * is a waste of time (because the NV cannot preserve
422 * the low-order bits anyway): we could just remember when
423 * did we overflow and in the end just multiply value_nv by the
424 * right amount of 8-tuples. */
425 value_nv += (NV)digit;
428 if (digit == ('_' - '0') && len && allow_underscores
429 && (digit = s[1] - '0') && (digit >= 0 && digit <= 7))
435 /* Allow \octal to work the DWIM way (that is, stop scanning
436 * as soon as non-octal characters are seen, complain only if
437 * someone seems to want to use the digits eight and nine). */
438 if (digit == 8 || digit == 9) {
439 if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT))
440 Perl_ck_warner(aTHX_ packWARN(WARN_DIGIT),
441 "Illegal octal digit '%c' ignored", *s);
446 if ( ( overflowed && value_nv > 4294967295.0)
448 || (!overflowed && value > 0xffffffff
449 && ! (*flags & PERL_SCAN_SILENT_NON_PORTABLE))
452 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
453 "Octal number > 037777777777 non-portable");
460 *flags = PERL_SCAN_GREATER_THAN_UV_MAX;
469 For backwards compatibility. Use C<grok_bin> instead.
473 For backwards compatibility. Use C<grok_hex> instead.
477 For backwards compatibility. Use C<grok_oct> instead.
483 Perl_scan_bin(pTHX_ const char *start, STRLEN len, STRLEN *retlen)
486 I32 flags = *retlen ? PERL_SCAN_ALLOW_UNDERSCORES : 0;
487 const UV ruv = grok_bin (start, &len, &flags, &rnv);
489 PERL_ARGS_ASSERT_SCAN_BIN;
492 return (flags & PERL_SCAN_GREATER_THAN_UV_MAX) ? rnv : (NV)ruv;
496 Perl_scan_oct(pTHX_ const char *start, STRLEN len, STRLEN *retlen)
499 I32 flags = *retlen ? PERL_SCAN_ALLOW_UNDERSCORES : 0;
500 const UV ruv = grok_oct (start, &len, &flags, &rnv);
502 PERL_ARGS_ASSERT_SCAN_OCT;
505 return (flags & PERL_SCAN_GREATER_THAN_UV_MAX) ? rnv : (NV)ruv;
509 Perl_scan_hex(pTHX_ const char *start, STRLEN len, STRLEN *retlen)
512 I32 flags = *retlen ? PERL_SCAN_ALLOW_UNDERSCORES : 0;
513 const UV ruv = grok_hex (start, &len, &flags, &rnv);
515 PERL_ARGS_ASSERT_SCAN_HEX;
518 return (flags & PERL_SCAN_GREATER_THAN_UV_MAX) ? rnv : (NV)ruv;
522 =for apidoc grok_numeric_radix
524 Scan and skip for a numeric decimal separator (radix).
529 Perl_grok_numeric_radix(pTHX_ const char **sp, const char *send)
531 #ifdef USE_LOCALE_NUMERIC
534 PERL_ARGS_ASSERT_GROK_NUMERIC_RADIX;
536 if (PL_numeric_radix_sv && IN_SOME_LOCALE_FORM) {
538 const char * const radix = SvPV(PL_numeric_radix_sv, len);
539 if (*sp + len <= send && memEQ(*sp, radix, len)) {
544 /* always try "." if numeric radix didn't match because
545 * we may have data from different locales mixed */
548 PERL_ARGS_ASSERT_GROK_NUMERIC_RADIX;
550 if (*sp < send && **sp == '.') {
558 =for apidoc grok_number
560 Recognise (or not) a number. The type of the number is returned
561 (0 if unrecognised), otherwise it is a bit-ORed combination of
562 IS_NUMBER_IN_UV, IS_NUMBER_GREATER_THAN_UV_MAX, IS_NUMBER_NOT_INT,
563 IS_NUMBER_NEG, IS_NUMBER_INFINITY, IS_NUMBER_NAN (defined in perl.h).
565 If the value of the number can fit an in UV, it is returned in the *valuep
566 IS_NUMBER_IN_UV will be set to indicate that *valuep is valid, IS_NUMBER_IN_UV
567 will never be set unless *valuep is valid, but *valuep may have been assigned
568 to during processing even though IS_NUMBER_IN_UV is not set on return.
569 If valuep is NULL, IS_NUMBER_IN_UV will be set for the same cases as when
570 valuep is non-NULL, but no actual assignment (or SEGV) will occur.
572 IS_NUMBER_NOT_INT will be set with IS_NUMBER_IN_UV if trailing decimals were
573 seen (in which case *valuep gives the true value truncated to an integer), and
574 IS_NUMBER_NEG if the number is negative (in which case *valuep holds the
575 absolute value). IS_NUMBER_IN_UV is not set if e notation was used or the
576 number is larger than a UV.
581 Perl_grok_number(pTHX_ const char *pv, STRLEN len, UV *valuep)
584 const char * const send = pv + len;
585 const UV max_div_10 = UV_MAX / 10;
586 const char max_mod_10 = UV_MAX % 10;
591 PERL_ARGS_ASSERT_GROK_NUMBER;
593 while (s < send && isSPACE(*s))
597 } else if (*s == '-') {
599 numtype = IS_NUMBER_NEG;
607 /* next must be digit or the radix separator or beginning of infinity */
609 /* UVs are at least 32 bits, so the first 9 decimal digits cannot
612 /* This construction seems to be more optimiser friendly.
613 (without it gcc does the isDIGIT test and the *s - '0' separately)
614 With it gcc on arm is managing 6 instructions (6 cycles) per digit.
615 In theory the optimiser could deduce how far to unroll the loop
616 before checking for overflow. */
618 int digit = *s - '0';
619 if (digit >= 0 && digit <= 9) {
620 value = value * 10 + digit;
623 if (digit >= 0 && digit <= 9) {
624 value = value * 10 + digit;
627 if (digit >= 0 && digit <= 9) {
628 value = value * 10 + digit;
631 if (digit >= 0 && digit <= 9) {
632 value = value * 10 + digit;
635 if (digit >= 0 && digit <= 9) {
636 value = value * 10 + digit;
639 if (digit >= 0 && digit <= 9) {
640 value = value * 10 + digit;
643 if (digit >= 0 && digit <= 9) {
644 value = value * 10 + digit;
647 if (digit >= 0 && digit <= 9) {
648 value = value * 10 + digit;
650 /* Now got 9 digits, so need to check
651 each time for overflow. */
653 while (digit >= 0 && digit <= 9
654 && (value < max_div_10
655 || (value == max_div_10
656 && digit <= max_mod_10))) {
657 value = value * 10 + digit;
663 if (digit >= 0 && digit <= 9
666 skip the remaining digits, don't
667 worry about setting *valuep. */
670 } while (s < send && isDIGIT(*s));
672 IS_NUMBER_GREATER_THAN_UV_MAX;
692 numtype |= IS_NUMBER_IN_UV;
697 if (GROK_NUMERIC_RADIX(&s, send)) {
698 numtype |= IS_NUMBER_NOT_INT;
699 while (s < send && isDIGIT(*s)) /* optional digits after the radix */
703 else if (GROK_NUMERIC_RADIX(&s, send)) {
704 numtype |= IS_NUMBER_NOT_INT | IS_NUMBER_IN_UV; /* valuep assigned below */
705 /* no digits before the radix means we need digits after it */
706 if (s < send && isDIGIT(*s)) {
709 } while (s < send && isDIGIT(*s));
711 /* integer approximation is valid - it's 0. */
717 } else if (*s == 'I' || *s == 'i') {
718 s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
719 s++; if (s == send || (*s != 'F' && *s != 'f')) return 0;
720 s++; if (s < send && (*s == 'I' || *s == 'i')) {
721 s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
722 s++; if (s == send || (*s != 'I' && *s != 'i')) return 0;
723 s++; if (s == send || (*s != 'T' && *s != 't')) return 0;
724 s++; if (s == send || (*s != 'Y' && *s != 'y')) return 0;
728 } else if (*s == 'N' || *s == 'n') {
729 /* XXX TODO: There are signaling NaNs and quiet NaNs. */
730 s++; if (s == send || (*s != 'A' && *s != 'a')) return 0;
731 s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
738 numtype &= IS_NUMBER_NEG; /* Keep track of sign */
739 numtype |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT;
741 numtype &= IS_NUMBER_NEG; /* Keep track of sign */
742 numtype |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT;
743 } else if (s < send) {
744 /* we can have an optional exponent part */
745 if (*s == 'e' || *s == 'E') {
746 /* The only flag we keep is sign. Blow away any "it's UV" */
747 numtype &= IS_NUMBER_NEG;
748 numtype |= IS_NUMBER_NOT_INT;
750 if (s < send && (*s == '-' || *s == '+'))
752 if (s < send && isDIGIT(*s)) {
755 } while (s < send && isDIGIT(*s));
761 while (s < send && isSPACE(*s))
765 if (len == 10 && memEQ(pv, "0 but true", 10)) {
768 return IS_NUMBER_IN_UV;
774 S_mulexp10(NV value, I32 exponent)
786 /* On OpenVMS VAX we by default use the D_FLOAT double format,
787 * and that format does not have *easy* capabilities [1] for
788 * overflowing doubles 'silently' as IEEE fp does. We also need
789 * to support G_FLOAT on both VAX and Alpha, and though the exponent
790 * range is much larger than D_FLOAT it still doesn't do silent
791 * overflow. Therefore we need to detect early whether we would
792 * overflow (this is the behaviour of the native string-to-float
793 * conversion routines, and therefore of native applications, too).
795 * [1] Trying to establish a condition handler to trap floating point
796 * exceptions is not a good idea. */
798 /* In UNICOS and in certain Cray models (such as T90) there is no
799 * IEEE fp, and no way at all from C to catch fp overflows gracefully.
800 * There is something you can do if you are willing to use some
801 * inline assembler: the instruction is called DFI-- but that will
802 * disable *all* floating point interrupts, a little bit too large
803 * a hammer. Therefore we need to catch potential overflows before
806 #if ((defined(VMS) && !defined(__IEEE_FP)) || defined(_UNICOS)) && defined(NV_MAX_10_EXP)
808 const NV exp_v = log10(value);
809 if (exponent >= NV_MAX_10_EXP || exponent + exp_v >= NV_MAX_10_EXP)
812 if (-(exponent + exp_v) >= NV_MAX_10_EXP)
814 while (-exponent >= NV_MAX_10_EXP) {
815 /* combination does not overflow, but 10^(-exponent) does */
825 exponent = -exponent;
827 for (bit = 1; exponent; bit <<= 1) {
828 if (exponent & bit) {
831 /* Floating point exceptions are supposed to be turned off,
832 * but if we're obviously done, don't risk another iteration.
834 if (exponent == 0) break;
838 return negative ? value / result : value * result;
842 Perl_my_atof(pTHX_ const char* s)
845 #ifdef USE_LOCALE_NUMERIC
848 PERL_ARGS_ASSERT_MY_ATOF;
850 if (PL_numeric_local && IN_SOME_LOCALE_FORM) {
853 /* Scan the number twice; once using locale and once without;
854 * choose the larger result (in absolute value). */
856 SET_NUMERIC_STANDARD();
859 if ((y < 0.0 && y < x) || (y > 0.0 && y > x))
871 Perl_my_atof2(pTHX_ const char* orig, NV* value)
873 NV result[3] = {0.0, 0.0, 0.0};
874 const char* s = orig;
876 UV accumulator[2] = {0,0}; /* before/after dp */
878 const char* send = s + strlen(orig) - 1;
880 I32 exp_adjust[2] = {0,0};
881 I32 exp_acc[2] = {-1, -1};
882 /* the current exponent adjust for the accumulators */
887 I32 sig_digits = 0; /* noof significant digits seen so far */
889 PERL_ARGS_ASSERT_MY_ATOF2;
891 /* There is no point in processing more significant digits
892 * than the NV can hold. Note that NV_DIG is a lower-bound value,
893 * while we need an upper-bound value. We add 2 to account for this;
894 * since it will have been conservative on both the first and last digit.
895 * For example a 32-bit mantissa with an exponent of 4 would have
896 * exact values in the set
904 * where for the purposes of calculating NV_DIG we would have to discount
905 * both the first and last digit, since neither can hold all values from
906 * 0..9; but for calculating the value we must examine those two digits.
908 #ifdef MAX_SIG_DIG_PLUS
909 /* It is not necessarily the case that adding 2 to NV_DIG gets all the
910 possible digits in a NV, especially if NVs are not IEEE compliant
911 (e.g., long doubles on IRIX) - Allen <allens@cpan.org> */
912 # define MAX_SIG_DIGITS (NV_DIG+MAX_SIG_DIG_PLUS)
914 # define MAX_SIG_DIGITS (NV_DIG+2)
917 /* the max number we can accumulate in a UV, and still safely do 10*N+9 */
918 #define MAX_ACCUMULATE ( (UV) ((UV_MAX - 9)/10))
920 /* leading whitespace */
933 /* punt to strtod for NaN/Inf; if no support for it there, tough luck */
936 if (*s == 'n' || *s == 'N' || *s == 'i' || *s == 'I') {
937 const char *p = negative ? s - 1 : s;
940 rslt = strtod(p, &endp);
948 /* we accumulate digits into an integer; when this becomes too
949 * large, we add the total to NV and start again */
959 /* don't start counting until we see the first significant
960 * digit, eg the 5 in 0.00005... */
961 if (!sig_digits && digit == 0)
964 if (++sig_digits > MAX_SIG_DIGITS) {
965 /* limits of precision reached */
967 ++accumulator[seen_dp];
968 } else if (digit == 5) {
969 if (old_digit % 2) { /* round to even - Allen */
970 ++accumulator[seen_dp];
978 /* skip remaining digits */
979 while (isDIGIT(*s)) {
985 /* warn of loss of precision? */
988 if (accumulator[seen_dp] > MAX_ACCUMULATE) {
989 /* add accumulator to result and start again */
990 result[seen_dp] = S_mulexp10(result[seen_dp],
992 + (NV)accumulator[seen_dp];
993 accumulator[seen_dp] = 0;
994 exp_acc[seen_dp] = 0;
996 accumulator[seen_dp] = accumulator[seen_dp] * 10 + digit;
1000 else if (!seen_dp && GROK_NUMERIC_RADIX(&s, send)) {
1002 if (sig_digits > MAX_SIG_DIGITS) {
1005 } while (isDIGIT(*s));
1014 result[0] = S_mulexp10(result[0], exp_acc[0]) + (NV)accumulator[0];
1016 result[1] = S_mulexp10(result[1], exp_acc[1]) + (NV)accumulator[1];
1019 if (seen_digit && (*s == 'e' || *s == 'E')) {
1020 bool expnegative = 0;
1031 exponent = exponent * 10 + (*s++ - '0');
1033 exponent = -exponent;
1038 /* now apply the exponent */
1041 result[2] = S_mulexp10(result[0],exponent+exp_adjust[0])
1042 + S_mulexp10(result[1],exponent-exp_adjust[1]);
1044 result[2] = S_mulexp10(result[0],exponent+exp_adjust[0]);
1047 /* now apply the sign */
1049 result[2] = -result[2];
1050 #endif /* USE_PERL_ATOF */
1055 #if ! defined(HAS_MODFL) && defined(HAS_AINTL) && defined(HAS_COPYSIGNL)
1057 Perl_my_modfl(long double x, long double *ip)
1060 return (x == *ip ? copysignl(0.0L, x) : x - *ip);
1064 #if ! defined(HAS_FREXPL) && defined(HAS_ILOGBL) && defined(HAS_SCALBNL)
1066 Perl_my_frexpl(long double x, int *e) {
1067 *e = x == 0.0L ? 0 : ilogbl(x) + 1;
1068 return (scalbnl(x, -*e));
1073 =for apidoc Perl_signbit
1075 Return a non-zero integer if the sign bit on an NV is set, and 0 if
1078 If Configure detects this system has a signbit() that will work with
1079 our NVs, then we just use it via the #define in perl.h. Otherwise,
1080 fall back on this implementation. As a first pass, this gets everything
1081 right except -0.0. Alas, catching -0.0 is the main use for this function,
1082 so this is not too helpful yet. Still, at least we have the scaffolding
1083 in place to support other systems, should that prove useful.
1086 Configure notes: This function is called 'Perl_signbit' instead of a
1087 plain 'signbit' because it is easy to imagine a system having a signbit()
1088 function or macro that doesn't happen to work with our particular choice
1089 of NVs. We shouldn't just re-#define signbit as Perl_signbit and expect
1090 the standard system headers to be happy. Also, this is a no-context
1091 function (no pTHX_) because Perl_signbit() is usually re-#defined in
1092 perl.h as a simple macro call to the system's signbit().
1093 Users should just always call Perl_signbit().
1097 #if !defined(HAS_SIGNBIT)
1099 Perl_signbit(NV x) {
1100 return (x < 0.0) ? 1 : 0;
1106 * c-indentation-style: bsd
1108 * indent-tabs-mode: nil
1111 * ex: set ts=8 sts=4 sw=4 et: