3 * Copyright (c) 2001, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "That only makes eleven (plus one mislaid) and not fourteen, unless
12 * wizards count differently to other people."
16 #define PERL_IN_NUMERIC_C
20 Perl_cast_ulong(pTHX_ NV f)
23 return f < I32_MIN ? (U32) I32_MIN : (U32)(I32) f;
26 if (f < U32_MAX_P1_HALF)
29 return ((U32) f) | (1 + U32_MAX >> 1);
34 return f > 0 ? U32_MAX : 0 /* NaN */;
38 Perl_cast_i32(pTHX_ NV f)
41 return f < I32_MIN ? I32_MIN : (I32) f;
44 if (f < U32_MAX_P1_HALF)
47 return (I32)(((U32) f) | (1 + U32_MAX >> 1));
52 return f > 0 ? (I32)U32_MAX : 0 /* NaN */;
56 Perl_cast_iv(pTHX_ NV f)
59 return f < IV_MIN ? IV_MIN : (IV) f;
62 /* For future flexibility allowing for sizeof(UV) >= sizeof(IV) */
63 if (f < UV_MAX_P1_HALF)
66 return (IV)(((UV) f) | (1 + UV_MAX >> 1));
71 return f > 0 ? (IV)UV_MAX : 0 /* NaN */;
75 Perl_cast_uv(pTHX_ NV f)
78 return f < IV_MIN ? (UV) IV_MIN : (UV)(IV) f;
81 if (f < UV_MAX_P1_HALF)
84 return ((UV) f) | (1 + UV_MAX >> 1);
89 return f > 0 ? UV_MAX : 0 /* NaN */;
92 #if defined(HUGE_VAL) || (defined(USE_LONG_DOUBLE) && defined(HUGE_VALL))
94 * This hack is to force load of "huge" support from libm.a
95 * So it is in perl for (say) POSIX to use.
96 * Needed for SunOS with Sun's 'acc' for example.
101 # if defined(USE_LONG_DOUBLE) && defined(HUGE_VALL)
111 converts a string representing a binary number to numeric form.
113 On entry I<start> and I<*len> give the string to scan, I<*flags> gives
114 conversion flags, and I<result> should be NULL or a pointer to an NV.
115 The scan stops at the end of the string, or the first invalid character.
116 On return I<*len> is set to the length scanned string, and I<*flags> gives
119 If the value is <= UV_MAX it is returned as a UV, the output flags are clear,
120 and nothing is written to I<*result>. If the value is > UV_MAX C<grok_bin>
121 returns UV_MAX, sets C<PERL_SCAN_GREATER_THAN_UV_MAX> in the output flags,
122 and writes the value to I<*result> (or the value is discarded if I<result>
125 The hex number may optinally be prefixed with "0b" or "b". If
126 C<PERL_SCAN_ALLOW_UNDERSCORES> is set in I<*flags> on entry then the binary
127 number may use '_' characters to separate digits.
133 Perl_grok_bin(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result) {
134 const char *s = start;
139 const UV max_div_2 = UV_MAX / 2;
140 bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES;
141 bool overflowed = FALSE;
143 /* strip off leading b or 0b.
144 for compatibility silently suffer "b" and "0b" as valid binary numbers.
151 else if (len >= 2 && s[0] == '0' && s[1] == 'b') {
157 for (; len-- && *s; s++) {
159 if (bit == '0' || bit == '1') {
160 /* Write it in this wonky order with a goto to attempt to get the
161 compiler to make the common case integer-only loop pretty tight.
162 With gcc seems to be much straighter code than old scan_bin. */
165 if (value <= max_div_2) {
166 value = (value << 1) | (bit - '0');
169 /* Bah. We're just overflowed. */
170 if (ckWARN_d(WARN_OVERFLOW))
171 Perl_warner(aTHX_ WARN_OVERFLOW,
172 "Integer overflow in binary number");
174 value_nv = (NV) value;
177 /* If an NV has not enough bits in its mantissa to
178 * represent an UV this summing of small low-order numbers
179 * is a waste of time (because the NV cannot preserve
180 * the low-order bits anyway): we could just remember when
181 * did we overflow and in the end just multiply value_nv by the
183 value_nv += (NV)(bit - '0');
186 if (bit == '_' && len && allow_underscores && (bit = s[1])
187 && (bit == '0' || bit == '1'))
193 if (ckWARN(WARN_DIGIT))
194 Perl_warner(aTHX_ WARN_DIGIT,
195 "Illegal binary digit '%c' ignored", *s);
199 if ( ( overflowed && value_nv > 4294967295.0)
201 || (!overflowed && value > 0xffffffff )
204 if (ckWARN(WARN_PORTABLE))
205 Perl_warner(aTHX_ WARN_PORTABLE,
206 "Binary number > 0b11111111111111111111111111111111 non-portable");
213 *flags = PERL_SCAN_GREATER_THAN_UV_MAX;
222 converts a string representing a hex number to numeric form.
224 On entry I<start> and I<*len> give the string to scan, I<*flags> gives
225 conversion flags, and I<result> should be NULL or a pointer to an NV.
226 The scan stops at the end of the string, or the first non-hex-digit character.
227 On return I<*len> is set to the length scanned string, and I<*flags> gives
230 If the value is <= UV_MAX it is returned as a UV, the output flags are clear,
231 and nothing is written to I<*result>. If the value is > UV_MAX C<grok_hex>
232 returns UV_MAX, sets C<PERL_SCAN_GREATER_THAN_UV_MAX> in the output flags,
233 and writes the value to I<*result> (or the value is discarded if I<result>
236 The hex number may optinally be prefixed with "0x" or "x". If
237 C<PERL_SCAN_ALLOW_UNDERSCORES> is set in I<*flags> on entry then the hex
238 number may use '_' characters to separate digits.
244 Perl_grok_hex(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result) {
245 const char *s = start;
250 const UV max_div_16 = UV_MAX / 16;
251 bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES;
252 bool overflowed = FALSE;
253 const char *hexdigit;
255 /* strip off leading x or 0x.
256 for compatibility silently suffer "x" and "0x" as valid hex numbers. */
262 else if (len >= 2 && s[0] == '0' && s[1] == 'x') {
268 for (; len-- && *s; s++) {
269 hexdigit = strchr((char *) PL_hexdigit, *s);
271 /* Write it in this wonky order with a goto to attempt to get the
272 compiler to make the common case integer-only loop pretty tight.
273 With gcc seems to be much straighter code than old scan_hex. */
276 if (value <= max_div_16) {
277 value = (value << 4) | ((hexdigit - PL_hexdigit) & 15);
280 /* Bah. We're just overflowed. */
281 if (ckWARN_d(WARN_OVERFLOW))
282 Perl_warner(aTHX_ WARN_OVERFLOW,
283 "Integer overflow in hexadecimal number");
285 value_nv = (NV) value;
288 /* If an NV has not enough bits in its mantissa to
289 * represent an UV this summing of small low-order numbers
290 * is a waste of time (because the NV cannot preserve
291 * the low-order bits anyway): we could just remember when
292 * did we overflow and in the end just multiply value_nv by the
293 * right amount of 16-tuples. */
294 value_nv += (NV)((hexdigit - PL_hexdigit) & 15);
297 if (*s == '_' && len && allow_underscores && s[1]
298 && (hexdigit = strchr((char *) PL_hexdigit, s[1])))
304 if (ckWARN(WARN_DIGIT))
305 Perl_warner(aTHX_ WARN_DIGIT,
306 "Illegal hexadecimal digit '%c' ignored", *s);
310 if ( ( overflowed && value_nv > 4294967295.0)
312 || (!overflowed && value > 0xffffffff )
315 if (ckWARN(WARN_PORTABLE))
316 Perl_warner(aTHX_ WARN_PORTABLE,
317 "Hexadecimal number > 0xffffffff non-portable");
324 *flags = PERL_SCAN_GREATER_THAN_UV_MAX;
338 Perl_grok_oct(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result) {
339 const char *s = start;
344 const UV max_div_8 = UV_MAX / 8;
345 bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES;
346 bool overflowed = FALSE;
348 for (; len-- && *s; s++) {
349 /* gcc 2.95 optimiser not smart enough to figure that this subtraction
350 out front allows slicker code. */
351 int digit = *s - '0';
352 if (digit >= 0 && digit <= 7) {
353 /* Write it in this wonky order with a goto to attempt to get the
354 compiler to make the common case integer-only loop pretty tight.
358 if (value <= max_div_8) {
359 value = (value << 3) | digit;
362 /* Bah. We're just overflowed. */
363 if (ckWARN_d(WARN_OVERFLOW))
364 Perl_warner(aTHX_ WARN_OVERFLOW,
365 "Integer overflow in octal number");
367 value_nv = (NV) value;
370 /* If an NV has not enough bits in its mantissa to
371 * represent an UV this summing of small low-order numbers
372 * is a waste of time (because the NV cannot preserve
373 * the low-order bits anyway): we could just remember when
374 * did we overflow and in the end just multiply value_nv by the
375 * right amount of 8-tuples. */
376 value_nv += (NV)digit;
379 if (digit == ('_' - '0') && len && allow_underscores
380 && (digit = s[1] - '0') && (digit >= 0 && digit <= 7))
386 /* Allow \octal to work the DWIM way (that is, stop scanning
387 * as soon as non-octal characters are seen, complain only iff
388 * someone seems to want to use the digits eight and nine). */
389 if (digit == 8 || digit == 9) {
390 if (ckWARN(WARN_DIGIT))
391 Perl_warner(aTHX_ WARN_DIGIT,
392 "Illegal octal digit '%c' ignored", *s);
397 if ( ( overflowed && value_nv > 4294967295.0)
399 || (!overflowed && value > 0xffffffff )
402 if (ckWARN(WARN_PORTABLE))
403 Perl_warner(aTHX_ WARN_PORTABLE,
404 "Octal number > 037777777777 non-portable");
411 *flags = PERL_SCAN_GREATER_THAN_UV_MAX;
420 For backwards compatibility. Use C<grok_bin> instead.
424 For backwards compatibility. Use C<grok_hex> instead.
428 For backwards compatibility. Use C<grok_oct> instead.
434 Perl_scan_bin(pTHX_ char *start, STRLEN len, STRLEN *retlen)
437 I32 flags = *retlen ? PERL_SCAN_ALLOW_UNDERSCORES : 0;
438 UV ruv = grok_bin (start, &len, &flags, &rnv);
441 return (flags & PERL_SCAN_GREATER_THAN_UV_MAX) ? rnv : (NV)ruv;
445 Perl_scan_oct(pTHX_ char *start, STRLEN len, STRLEN *retlen)
448 I32 flags = *retlen ? PERL_SCAN_ALLOW_UNDERSCORES : 0;
449 UV ruv = grok_oct (start, &len, &flags, &rnv);
452 return (flags & PERL_SCAN_GREATER_THAN_UV_MAX) ? rnv : (NV)ruv;
456 Perl_scan_hex(pTHX_ char *start, STRLEN len, STRLEN *retlen)
459 I32 flags = *retlen ? PERL_SCAN_ALLOW_UNDERSCORES : 0;
460 UV ruv = grok_hex (start, &len, &flags, &rnv);
463 return (flags & PERL_SCAN_GREATER_THAN_UV_MAX) ? rnv : (NV)ruv;
467 =for apidoc grok_numeric_radix
469 Scan and skip for a numeric decimal separator (radix).
474 Perl_grok_numeric_radix(pTHX_ const char **sp, const char *send)
476 #ifdef USE_LOCALE_NUMERIC
477 if (PL_numeric_radix_sv && IN_LOCALE) {
479 char* radix = SvPV(PL_numeric_radix_sv, len);
480 if (*sp + len <= send && memEQ(*sp, radix, len)) {
485 /* always try "." if numeric radix didn't match because
486 * we may have data from different locales mixed */
488 if (*sp < send && **sp == '.') {
496 =for apidoc grok_number
498 Recognise (or not) a number. The type of the number is returned
499 (0 if unrecognised), otherwise it is a bit-ORed combination of
500 IS_NUMBER_IN_UV, IS_NUMBER_GREATER_THAN_UV_MAX, IS_NUMBER_NOT_INT,
501 IS_NUMBER_NEG, IS_NUMBER_INFINITY, IS_NUMBER_NAN (defined in perl.h).
503 If the value of the number can fit an in UV, it is returned in the *valuep
504 IS_NUMBER_IN_UV will be set to indicate that *valuep is valid, IS_NUMBER_IN_UV
505 will never be set unless *valuep is valid, but *valuep may have been assigned
506 to during processing even though IS_NUMBER_IN_UV is not set on return.
507 If valuep is NULL, IS_NUMBER_IN_UV will be set for the same cases as when
508 valuep is non-NULL, but no actual assignment (or SEGV) will occur.
510 IS_NUMBER_NOT_INT will be set with IS_NUMBER_IN_UV if trailing decimals were
511 seen (in which case *valuep gives the true value truncated to an integer), and
512 IS_NUMBER_NEG if the number is negative (in which case *valuep holds the
513 absolute value). IS_NUMBER_IN_UV is not set if e notation was used or the
514 number is larger than a UV.
519 Perl_grok_number(pTHX_ const char *pv, STRLEN len, UV *valuep)
522 const char *send = pv + len;
523 const UV max_div_10 = UV_MAX / 10;
524 const char max_mod_10 = UV_MAX % 10;
529 while (s < send && isSPACE(*s))
533 } else if (*s == '-') {
535 numtype = IS_NUMBER_NEG;
543 /* next must be digit or the radix separator or beginning of infinity */
545 /* UVs are at least 32 bits, so the first 9 decimal digits cannot
548 /* This construction seems to be more optimiser friendly.
549 (without it gcc does the isDIGIT test and the *s - '0' separately)
550 With it gcc on arm is managing 6 instructions (6 cycles) per digit.
551 In theory the optimiser could deduce how far to unroll the loop
552 before checking for overflow. */
554 int digit = *s - '0';
555 if (digit >= 0 && digit <= 9) {
556 value = value * 10 + digit;
559 if (digit >= 0 && digit <= 9) {
560 value = value * 10 + digit;
563 if (digit >= 0 && digit <= 9) {
564 value = value * 10 + digit;
567 if (digit >= 0 && digit <= 9) {
568 value = value * 10 + digit;
571 if (digit >= 0 && digit <= 9) {
572 value = value * 10 + digit;
575 if (digit >= 0 && digit <= 9) {
576 value = value * 10 + digit;
579 if (digit >= 0 && digit <= 9) {
580 value = value * 10 + digit;
583 if (digit >= 0 && digit <= 9) {
584 value = value * 10 + digit;
586 /* Now got 9 digits, so need to check
587 each time for overflow. */
589 while (digit >= 0 && digit <= 9
590 && (value < max_div_10
591 || (value == max_div_10
592 && digit <= max_mod_10))) {
593 value = value * 10 + digit;
599 if (digit >= 0 && digit <= 9
602 skip the remaining digits, don't
603 worry about setting *valuep. */
606 } while (s < send && isDIGIT(*s));
608 IS_NUMBER_GREATER_THAN_UV_MAX;
628 numtype |= IS_NUMBER_IN_UV;
633 if (GROK_NUMERIC_RADIX(&s, send)) {
634 numtype |= IS_NUMBER_NOT_INT;
635 while (s < send && isDIGIT(*s)) /* optional digits after the radix */
639 else if (GROK_NUMERIC_RADIX(&s, send)) {
640 numtype |= IS_NUMBER_NOT_INT | IS_NUMBER_IN_UV; /* valuep assigned below */
641 /* no digits before the radix means we need digits after it */
642 if (s < send && isDIGIT(*s)) {
645 } while (s < send && isDIGIT(*s));
647 /* integer approximation is valid - it's 0. */
653 } else if (*s == 'I' || *s == 'i') {
654 s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
655 s++; if (s == send || (*s != 'F' && *s != 'f')) return 0;
656 s++; if (s < send && (*s == 'I' || *s == 'i')) {
657 s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
658 s++; if (s == send || (*s != 'I' && *s != 'i')) return 0;
659 s++; if (s == send || (*s != 'T' && *s != 't')) return 0;
660 s++; if (s == send || (*s != 'Y' && *s != 'y')) return 0;
664 } else if (*s == 'N' || *s == 'n') {
665 /* XXX TODO: There are signaling NaNs and quiet NaNs. */
666 s++; if (s == send || (*s != 'A' && *s != 'a')) return 0;
667 s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
674 numtype &= IS_NUMBER_NEG; /* Keep track of sign */
675 numtype |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT;
677 numtype &= IS_NUMBER_NEG; /* Keep track of sign */
678 numtype |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT;
679 } else if (s < send) {
680 /* we can have an optional exponent part */
681 if (*s == 'e' || *s == 'E') {
682 /* The only flag we keep is sign. Blow away any "it's UV" */
683 numtype &= IS_NUMBER_NEG;
684 numtype |= IS_NUMBER_NOT_INT;
686 if (s < send && (*s == '-' || *s == '+'))
688 if (s < send && isDIGIT(*s)) {
691 } while (s < send && isDIGIT(*s));
697 while (s < send && isSPACE(*s))
701 if (len == 10 && memEQ(pv, "0 but true", 10)) {
704 return IS_NUMBER_IN_UV;
710 S_mulexp10(NV value, I32 exponent)
719 else if (exponent < 0) {
721 exponent = -exponent;
724 /* On OpenVMS VAX we by default use the D_FLOAT double format,
725 * and that format does not have *easy* capabilities [1] for
726 * overflowing doubles 'silently' as IEEE fp does. We also need
727 * to support G_FLOAT on both VAX and Alpha, and though the exponent
728 * range is much larger than D_FLOAT it still doesn't do silent
729 * overflow. Therefore we need to detect early whether we would
730 * overflow (this is the behaviour of the native string-to-float
731 * conversion routines, and therefore of native applications, too).
733 * [1] Trying to establish a condition handler to trap floating point
734 * exceptions is not a good idea. */
735 #if defined(VMS) && !defined(__IEEE_FP) && defined(NV_MAX_10_EXP)
737 (log10(value) + exponent) >= (NV_MAX_10_EXP))
741 /* In UNICOS and in certain Cray models (such as T90) there is no
742 * IEEE fp, and no way at all from C to catch fp overflows gracefully.
743 * There is something you can do if you are willing to use some
744 * inline assembler: the instruction is called DFI-- but that will
745 * disable *all* floating point interrupts, a little bit too large
746 * a hammer. Therefore we need to catch potential overflows before
748 #if defined(_UNICOS) && defined(NV_MAX_10_EXP)
750 (log10(value) + exponent) >= NV_MAX_10_EXP)
754 for (bit = 1; exponent; bit <<= 1) {
755 if (exponent & bit) {
759 /* Floating point exceptions are supposed to be turned off. */
762 return negative ? value / result : value * result;
766 Perl_my_atof(pTHX_ const char* s)
769 #ifdef USE_LOCALE_NUMERIC
770 if (PL_numeric_local && IN_LOCALE) {
773 /* Scan the number twice; once using locale and once without;
774 * choose the larger result (in absolute value). */
775 Perl_atof2(aTHX_ s, &x);
776 SET_NUMERIC_STANDARD();
777 Perl_atof2(aTHX_ s, &y);
779 if ((y < 0.0 && y < x) || (y > 0.0 && y > x))
783 Perl_atof2(aTHX_ s, &x);
785 Perl_atof2(aTHX_ s, &x);
791 Perl_my_atof2(pTHX_ const char* orig, NV* value)
795 char* s = (char*)orig;
796 char* send = s + strlen(orig) - 1;
801 /* this is arbitrary */
803 /* we want the largest integers we can usefully use */
804 #if defined(HAS_QUAD) && defined(USE_64_BIT_INT)
805 # define PARTSIZE ((int)TYPE_DIGITS(U64)-1)
808 # define PARTSIZE ((int)TYPE_DIGITS(U32)-1)
811 I32 ipart = 0; /* index into part[] */
812 I32 offcount; /* number of digits in least significant part */
814 /* leading whitespace */
827 part[0] = offcount = 0;
829 seendigit = 1; /* get this over with */
831 /* skip leading zeros */
837 while (isDIGIT(*s)) {
838 if (++offcount > PARTSIZE) {
839 if (++ipart < PARTLIM) {
841 offcount = 1; /* ++0 */
844 /* limits of precision reached */
849 while (isDIGIT(*s)) {
853 /* warn of loss of precision? */
857 part[ipart] = part[ipart] * 10 + (*s++ - '0');
861 if (GROK_NUMERIC_RADIX((const char **)&s, send)) {
863 seendigit = 1; /* get this over with */
866 while (isDIGIT(*s)) {
867 if (++offcount > PARTSIZE) {
868 if (++ipart < PARTLIM) {
870 offcount = 1; /* ++0 */
873 /* limits of precision reached */
880 /* warn of loss of precision? */
885 part[ipart] = part[ipart] * 10 + (*s++ - '0');
889 /* combine components of mantissa */
890 for (i = 0; i <= ipart; ++i)
891 result += S_mulexp10((NV)part[ipart - i],
892 i ? offcount + (i - 1) * PARTSIZE : 0);
894 if (seendigit && (*s == 'e' || *s == 'E')) {
895 bool expnegative = 0;
906 exponent = exponent * 10 + (*s++ - '0');
908 exponent = -exponent;
911 /* now apply the exponent */
912 exponent += expextra;
913 result = S_mulexp10(result, exponent);
915 /* now apply the sign */