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)
109 Perl_scan_bin(pTHX_ char *start, STRLEN len, STRLEN *retlen)
111 register char *s = start;
112 register NV rnv = 0.0;
114 register bool seenb = FALSE;
115 register bool overflowed = FALSE;
117 for (; len-- && *s; s++) {
118 if (!(*s == '0' || *s == '1')) {
119 if (*s == '_' && len && *retlen
120 && (s[1] == '0' || s[1] == '1'))
125 else if (seenb == FALSE && *s == 'b' && ruv == 0) {
126 /* Disallow 0bbb0b0bbb... */
131 if (ckWARN(WARN_DIGIT))
132 Perl_warner(aTHX_ WARN_DIGIT,
133 "Illegal binary digit '%c' ignored", *s);
138 register UV xuv = ruv << 1;
140 if ((xuv >> 1) != ruv) {
143 if (ckWARN_d(WARN_OVERFLOW))
144 Perl_warner(aTHX_ WARN_OVERFLOW,
145 "Integer overflow in binary number");
148 ruv = xuv | (*s - '0');
152 /* If an NV has not enough bits in its mantissa to
153 * represent an UV this summing of small low-order numbers
154 * is a waste of time (because the NV cannot preserve
155 * the low-order bits anyway): we could just remember when
156 * did we overflow and in the end just multiply rnv by the
163 if ( ( overflowed && rnv > 4294967295.0)
165 || (!overflowed && ruv > 0xffffffff )
168 if (ckWARN(WARN_PORTABLE))
169 Perl_warner(aTHX_ WARN_PORTABLE,
170 "Binary number > 0b11111111111111111111111111111111 non-portable");
177 Perl_scan_oct(pTHX_ char *start, STRLEN len, STRLEN *retlen)
179 register char *s = start;
180 register NV rnv = 0.0;
182 register bool overflowed = FALSE;
184 for (; len-- && *s; s++) {
185 if (!(*s >= '0' && *s <= '7')) {
186 if (*s == '_' && len && *retlen
187 && (s[1] >= '0' && s[1] <= '7'))
193 /* Allow \octal to work the DWIM way (that is, stop scanning
194 * as soon as non-octal characters are seen, complain only iff
195 * someone seems to want to use the digits eight and nine). */
196 if (*s == '8' || *s == '9') {
197 if (ckWARN(WARN_DIGIT))
198 Perl_warner(aTHX_ WARN_DIGIT,
199 "Illegal octal digit '%c' ignored", *s);
205 register UV xuv = ruv << 3;
207 if ((xuv >> 3) != ruv) {
210 if (ckWARN_d(WARN_OVERFLOW))
211 Perl_warner(aTHX_ WARN_OVERFLOW,
212 "Integer overflow in octal number");
215 ruv = xuv | (*s - '0');
219 /* If an NV has not enough bits in its mantissa to
220 * represent an UV this summing of small low-order numbers
221 * is a waste of time (because the NV cannot preserve
222 * the low-order bits anyway): we could just remember when
223 * did we overflow and in the end just multiply rnv by the
224 * right amount of 8-tuples. */
225 rnv += (NV)(*s - '0');
230 if ( ( overflowed && rnv > 4294967295.0)
232 || (!overflowed && ruv > 0xffffffff )
235 if (ckWARN(WARN_PORTABLE))
236 Perl_warner(aTHX_ WARN_PORTABLE,
237 "Octal number > 037777777777 non-portable");
244 Perl_scan_hex(pTHX_ char *start, STRLEN len, STRLEN *retlen)
246 register char *s = start;
247 register NV rnv = 0.0;
249 register bool overflowed = FALSE;
257 else if (len > 3 && s[0] == '0' && s[1] == 'x') {
263 for (; len-- && *s; s++) {
264 hexdigit = strchr((char *) PL_hexdigit, *s);
266 if (*s == '_' && len && *retlen && s[1]
267 && (hexdigit = strchr((char *) PL_hexdigit, s[1])))
273 if (ckWARN(WARN_DIGIT))
274 Perl_warner(aTHX_ WARN_DIGIT,
275 "Illegal hexadecimal digit '%c' ignored", *s);
280 register UV xuv = ruv << 4;
282 if ((xuv >> 4) != ruv) {
285 if (ckWARN_d(WARN_OVERFLOW))
286 Perl_warner(aTHX_ WARN_OVERFLOW,
287 "Integer overflow in hexadecimal number");
290 ruv = xuv | ((hexdigit - PL_hexdigit) & 15);
294 /* If an NV has not enough bits in its mantissa to
295 * represent an UV this summing of small low-order numbers
296 * is a waste of time (because the NV cannot preserve
297 * the low-order bits anyway): we could just remember when
298 * did we overflow and in the end just multiply rnv by the
299 * right amount of 16-tuples. */
300 rnv += (NV)((hexdigit - PL_hexdigit) & 15);
305 if ( ( overflowed && rnv > 4294967295.0)
307 || (!overflowed && ruv > 0xffffffff )
310 if (ckWARN(WARN_PORTABLE))
311 Perl_warner(aTHX_ WARN_PORTABLE,
312 "Hexadecimal number > 0xffffffff non-portable");
319 =for apidoc grok_numeric_radix
321 Scan and skip for a numeric decimal separator (radix).
326 Perl_grok_numeric_radix(pTHX_ const char **sp, const char *send)
328 #ifdef USE_LOCALE_NUMERIC
329 if (PL_numeric_radix_sv && IN_LOCALE) {
331 char* radix = SvPV(PL_numeric_radix_sv, len);
332 if (*sp + len <= send && memEQ(*sp, radix, len)) {
337 /* always try "." if numeric radix didn't match because
338 * we may have data from different locales mixed */
340 if (*sp < send && **sp == '.') {
348 =for apidoc grok_number
350 Recognise (or not) a number. The type of the number is returned
351 (0 if unrecognised), otherwise it is a bit-ORed combination of
352 IS_NUMBER_IN_UV, IS_NUMBER_GREATER_THAN_UV_MAX, IS_NUMBER_NOT_INT,
353 IS_NUMBER_NEG, IS_NUMBER_INFINITY, IS_NUMBER_NAN (defined in perl.h).
355 If the value of the number can fit an in UV, it is returned in the *valuep
356 IS_NUMBER_IN_UV will be set to indicate that *valuep is valid, IS_NUMBER_IN_UV
357 will never be set unless *valuep is valid, but *valuep may have been assigned
358 to during processing even though IS_NUMBER_IN_UV is not set on return.
359 If valuep is NULL, IS_NUMBER_IN_UV will be set for the same cases as when
360 valuep is non-NULL, but no actual assignment (or SEGV) will occur.
362 IS_NUMBER_NOT_INT will be set with IS_NUMBER_IN_UV if trailing decimals were
363 seen (in which case *valuep gives the true value truncated to an integer), and
364 IS_NUMBER_NEG if the number is negative (in which case *valuep holds the
365 absolute value). IS_NUMBER_IN_UV is not set if e notation was used or the
366 number is larger than a UV.
371 Perl_grok_number(pTHX_ const char *pv, STRLEN len, UV *valuep)
374 const char *send = pv + len;
375 const UV max_div_10 = UV_MAX / 10;
376 const char max_mod_10 = UV_MAX % 10;
381 while (s < send && isSPACE(*s))
385 } else if (*s == '-') {
387 numtype = IS_NUMBER_NEG;
395 /* next must be digit or the radix separator or beginning of infinity */
397 /* UVs are at least 32 bits, so the first 9 decimal digits cannot
400 /* This construction seems to be more optimiser friendly.
401 (without it gcc does the isDIGIT test and the *s - '0' separately)
402 With it gcc on arm is managing 6 instructions (6 cycles) per digit.
403 In theory the optimiser could deduce how far to unroll the loop
404 before checking for overflow. */
406 int digit = *s - '0';
407 if (digit >= 0 && digit <= 9) {
408 value = value * 10 + digit;
411 if (digit >= 0 && digit <= 9) {
412 value = value * 10 + digit;
415 if (digit >= 0 && digit <= 9) {
416 value = value * 10 + digit;
419 if (digit >= 0 && digit <= 9) {
420 value = value * 10 + digit;
423 if (digit >= 0 && digit <= 9) {
424 value = value * 10 + digit;
427 if (digit >= 0 && digit <= 9) {
428 value = value * 10 + digit;
431 if (digit >= 0 && digit <= 9) {
432 value = value * 10 + digit;
435 if (digit >= 0 && digit <= 9) {
436 value = value * 10 + digit;
438 /* Now got 9 digits, so need to check
439 each time for overflow. */
441 while (digit >= 0 && digit <= 9
442 && (value < max_div_10
443 || (value == max_div_10
444 && digit <= max_mod_10))) {
445 value = value * 10 + digit;
451 if (digit >= 0 && digit <= 9
454 skip the remaining digits, don't
455 worry about setting *valuep. */
458 } while (s < send && isDIGIT(*s));
460 IS_NUMBER_GREATER_THAN_UV_MAX;
480 numtype |= IS_NUMBER_IN_UV;
485 if (GROK_NUMERIC_RADIX(&s, send)) {
486 numtype |= IS_NUMBER_NOT_INT;
487 while (s < send && isDIGIT(*s)) /* optional digits after the radix */
491 else if (GROK_NUMERIC_RADIX(&s, send)) {
492 numtype |= IS_NUMBER_NOT_INT | IS_NUMBER_IN_UV; /* valuep assigned below */
493 /* no digits before the radix means we need digits after it */
494 if (s < send && isDIGIT(*s)) {
497 } while (s < send && isDIGIT(*s));
499 /* integer approximation is valid - it's 0. */
505 } else if (*s == 'I' || *s == 'i') {
506 s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
507 s++; if (s == send || (*s != 'F' && *s != 'f')) return 0;
508 s++; if (s < send && (*s == 'I' || *s == 'i')) {
509 s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
510 s++; if (s == send || (*s != 'I' && *s != 'i')) return 0;
511 s++; if (s == send || (*s != 'T' && *s != 't')) return 0;
512 s++; if (s == send || (*s != 'Y' && *s != 'y')) return 0;
516 } else if (*s == 'N' || *s == 'n') {
517 /* XXX TODO: There are signaling NaNs and quiet NaNs. */
518 s++; if (s == send || (*s != 'A' && *s != 'a')) return 0;
519 s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
526 numtype &= IS_NUMBER_NEG; /* Keep track of sign */
527 numtype |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT;
529 numtype &= IS_NUMBER_NEG; /* Keep track of sign */
530 numtype |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT;
531 } else if (s < send) {
532 /* we can have an optional exponent part */
533 if (*s == 'e' || *s == 'E') {
534 /* The only flag we keep is sign. Blow away any "it's UV" */
535 numtype &= IS_NUMBER_NEG;
536 numtype |= IS_NUMBER_NOT_INT;
538 if (s < send && (*s == '-' || *s == '+'))
540 if (s < send && isDIGIT(*s)) {
543 } while (s < send && isDIGIT(*s));
549 while (s < send && isSPACE(*s))
553 if (len == 10 && memEQ(pv, "0 but true", 10)) {
556 return IS_NUMBER_IN_UV;
562 S_mulexp10(NV value, I32 exponent)
571 else if (exponent < 0) {
573 exponent = -exponent;
575 #ifdef __VAX /* avoid %SYSTEM-F-FLTOVF_F sans VAXC$ESTABLISH */
576 # if defined(__DECC_VER) && __DECC_VER <= 50390006
577 /* __F_FLT_MAX_10_EXP - 5 == 33 */
579 (log10(value) + exponent) >= (__F_FLT_MAX_10_EXP - 5))
583 #if defined(__alpha) && defined(__unix__)
585 (log10(value) + exponent) >= (DBL_MAX_10_EXP))
588 for (bit = 1; exponent; bit <<= 1) {
589 if (exponent & bit) {
595 return negative ? value / result : value * result;
599 Perl_my_atof(pTHX_ const char* s)
602 #ifdef USE_LOCALE_NUMERIC
603 if (PL_numeric_local && IN_LOCALE) {
606 /* Scan the number twice; once using locale and once without;
607 * choose the larger result (in absolute value). */
608 Perl_atof2(aTHX_ s, &x);
609 SET_NUMERIC_STANDARD();
610 Perl_atof2(aTHX_ s, &y);
612 if ((y < 0.0 && y < x) || (y > 0.0 && y > x))
616 Perl_atof2(aTHX_ s, &x);
618 Perl_atof2(aTHX_ s, &x);
624 Perl_my_atof2(pTHX_ const char* orig, NV* value)
628 char* s = (char*)orig;
629 char* send = s + strlen(orig) - 1;
634 /* this is arbitrary */
636 /* we want the largest integers we can usefully use */
637 #if defined(HAS_QUAD) && defined(USE_64_BIT_INT)
638 # define PARTSIZE ((int)TYPE_DIGITS(U64)-1)
641 # define PARTSIZE ((int)TYPE_DIGITS(U32)-1)
644 I32 ipart = 0; /* index into part[] */
645 I32 offcount; /* number of digits in least significant part */
647 /* leading whitespace */
660 part[0] = offcount = 0;
662 seendigit = 1; /* get this over with */
664 /* skip leading zeros */
670 while (isDIGIT(*s)) {
671 if (++offcount > PARTSIZE) {
672 if (++ipart < PARTLIM) {
674 offcount = 1; /* ++0 */
677 /* limits of precision reached */
682 while (isDIGIT(*s)) {
686 /* warn of loss of precision? */
690 part[ipart] = part[ipart] * 10 + (*s++ - '0');
694 if (GROK_NUMERIC_RADIX((const char **)&s, send)) {
696 seendigit = 1; /* get this over with */
699 while (isDIGIT(*s)) {
700 if (++offcount > PARTSIZE) {
701 if (++ipart < PARTLIM) {
703 offcount = 1; /* ++0 */
706 /* limits of precision reached */
713 /* warn of loss of precision? */
718 part[ipart] = part[ipart] * 10 + (*s++ - '0');
722 /* combine components of mantissa */
723 for (i = 0; i <= ipart; ++i)
724 result += S_mulexp10((NV)part[ipart - i],
725 i ? offcount + (i - 1) * PARTSIZE : 0);
727 if (seendigit && (*s == 'e' || *s == 'E')) {
728 bool expnegative = 0;
739 exponent = exponent * 10 + (*s++ - '0');
741 exponent = -exponent;
744 /* now apply the exponent */
745 exponent += expextra;
746 result = S_mulexp10(result, exponent);
748 /* now apply the sign */