*/
/*
-=head1 Numeric functions
-
-=cut
This file contains all the stuff needed by perl for manipulating numeric
values, including such things as replacements for the OS's atof() function
digits may be separated from each other by a single underscore; also a single
leading underscore is accepted.
-The the C<PERL_SCAN_DISALLOW_PREFIX> flag is always treated as being set for
+The C<PERL_SCAN_DISALLOW_PREFIX> flag is always treated as being set for
this function.
=cut
/* In overflows, this keeps track of how much to multiply the overflowed NV
* by as we continue to parse the remaining digits */
- UV factor;
+ NV factor = 0;
/* This function unifies the core of grok_bin, grok_oct, and grok_hex. It
* is optimized for hex conversion. For example, it uses XDIGIT_VALUE to
s = s0; /* s0 potentially advanced from 'start' */
/* Unroll the loop so that the first 8 digits are branchless except for the
- * switch. A ninth one overflows a 32 bit word. */
+ * switch. A ninth hex one overflows a 32 bit word. */
switch (len) {
case 0:
return 0;
default:
- if (! _generic_isCC(*s, class_bit)) break;
+ if (UNLIKELY(! _generic_isCC(*s, class_bit))) break;
value = (value << shift) | XDIGIT_VALUE(*s);
s++;
/* FALLTHROUGH */
case 7:
- if (! _generic_isCC(*s, class_bit)) break;
+ if (UNLIKELY(! _generic_isCC(*s, class_bit))) break;
value = (value << shift) | XDIGIT_VALUE(*s);
s++;
/* FALLTHROUGH */
case 6:
- if (! _generic_isCC(*s, class_bit)) break;
+ if (UNLIKELY(! _generic_isCC(*s, class_bit))) break;
value = (value << shift) | XDIGIT_VALUE(*s);
s++;
/* FALLTHROUGH */
case 5:
- if (! _generic_isCC(*s, class_bit)) break;
+ if (UNLIKELY(! _generic_isCC(*s, class_bit))) break;
value = (value << shift) | XDIGIT_VALUE(*s);
s++;
/* FALLTHROUGH */
case 4:
- if (! _generic_isCC(*s, class_bit)) break;
+ if (UNLIKELY(! _generic_isCC(*s, class_bit))) break;
value = (value << shift) | XDIGIT_VALUE(*s);
s++;
/* FALLTHROUGH */
case 3:
- if (! _generic_isCC(*s, class_bit)) break;
+ if (UNLIKELY(! _generic_isCC(*s, class_bit))) break;
value = (value << shift) | XDIGIT_VALUE(*s);
s++;
/* FALLTHROUGH */
case 2:
- if (! _generic_isCC(*s, class_bit)) break;
+ if (UNLIKELY(! _generic_isCC(*s, class_bit))) break;
value = (value << shift) | XDIGIT_VALUE(*s);
s++;
/* FALLTHROUGH */
case 1:
- if (! _generic_isCC(*s, class_bit)) break;
+ if (UNLIKELY(! _generic_isCC(*s, class_bit))) break;
value = (value << shift) | XDIGIT_VALUE(*s);
if (LIKELY(len <= 8)) {
/* Note XDIGIT_VALUE() is branchless, works on binary
* and octal as well, so can be used here, without
* slowing those down */
- factor <<= shift;
+ factor *= 1 << shift;
continue;
}
* value. Each time through the loop we have increased 'factor' so
* that it gives how much the current approximation needs to
* effectively be shifted to make room for this new value */
- value_nv *= (NV) factor;
+ value_nv *= factor;
value_nv += (NV) value;
/* Then we keep accumulating digits, until all are parsed. We
if (! overflowed) {
overflowed = TRUE;
- Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
+ if ( ! (input_flags & PERL_SCAN_SILENT_OVERFLOW)
+ && ckWARN_d(WARN_OVERFLOW))
+ {
+ Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
"Integer overflow in %s number",
(base == 16) ? "hexadecimal"
: (base == 2)
? "binary"
: "octal");
+ }
}
continue;
}
if ( *s == '_'
&& len
&& allow_underscores
- && _generic_isCC(s[1], class_bit))
+ && _generic_isCC(s[1], class_bit)
+
+ /* Don't allow a leading underscore if the only-medial bit is
+ * set */
+ && ( LIKELY(s > s0)
+ || UNLIKELY((input_flags & PERL_SCAN_ALLOW_MEDIAL_UNDERSCORES)
+ != PERL_SCAN_ALLOW_MEDIAL_UNDERSCORES)))
{
--len;
++s;
if (*s) {
if ( ! (input_flags & PERL_SCAN_SILENT_ILLDIGIT)
- && ckWARN(WARN_DIGIT))
- {
- if (base != 8) {
- Perl_warner(aTHX_ packWARN(WARN_DIGIT),
- "Illegal %s digit '%c' ignored",
- ((base == 2)
- ? "binary"
- : "hexadecimal"),
- *s);
- }
- else if (isDIGIT(*s)) { /* octal base */
-
- /* Allow \octal to work the DWIM way (that is, stop scanning as
- * soon as non-octal characters are seen, complain only if
- * someone seems to want to use the digits eight and nine.
- * Since we know it is not octal, then if isDIGIT, must be an 8
- * or 9). */
- Perl_warner(aTHX_ packWARN(WARN_DIGIT),
+ && ckWARN(WARN_DIGIT))
+ {
+ if (base != 8) {
+ Perl_warner(aTHX_ packWARN(WARN_DIGIT),
+ "Illegal %s digit '%c' ignored",
+ ((base == 2)
+ ? "binary"
+ : "hexadecimal"),
+ *s);
+ }
+ else if (isDIGIT(*s)) { /* octal base */
+
+ /* Allow \octal to work the DWIM way (that is, stop
+ * scanning as soon as non-octal characters are seen,
+ * complain only if someone seems to want to use the digits
+ * eight and nine. Since we know it is not octal, then if
+ * isDIGIT, must be an 8 or 9). */
+ Perl_warner(aTHX_ packWARN(WARN_DIGIT),
"Illegal octal digit '%c' ignored", *s);
}
}
}
/* Overflowed: Calculate the final overflow approximation */
- value_nv *= (NV) factor;
+ value_nv *= factor;
value_nv += (NV) value;
output_non_portable(base);
one byte past the end of the recognized string. If the recognition fails,
zero is returned, and C<*sp> will not move.
-=for apidoc Amn|bool|IS_NUMBER_GREATER_THAN_UV_MAX
-=for apidoc Amn|bool|IS_NUMBER_INFINITY
-=for apidoc Amn|bool|IS_NUMBER_IN_UV
-=for apidoc Amn|bool|IS_NUMBER_NAN
-=for apidoc Amn|bool|IS_NUMBER_NEG
-=for apidoc Amn|bool|IS_NUMBER_NOT_INT
+=for apidoc Amnh|bool|IS_NUMBER_GREATER_THAN_UV_MAX
+=for apidoc Amnh|bool|IS_NUMBER_INFINITY
+=for apidoc Amnh|bool|IS_NUMBER_IN_UV
+=for apidoc Amnh|bool|IS_NUMBER_NAN
+=for apidoc Amnh|bool|IS_NUMBER_NEG
+=for apidoc Amnh|bool|IS_NUMBER_NOT_INT
=cut
*/
s++; if (s == send || isALPHA_FOLD_NE(*s, 'Y')) return fail;
s++;
} else if (odh) {
- while (*s == '0') { /* 1.#INF00 */
+ while (s < send && *s == '0') { /* 1.#INF00 */
s++;
}
}
else if (isALPHA_FOLD_EQ(*s, 'D') && odh) { /* 1.#IND */
s++;
flags |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT;
- while (*s == '0') { /* 1.#IND00 */
+ while (s < send && *s == '0') { /* 1.#IND00 */
s++;
}
- if (*s) {
+ if (s < send && *s) {
flags |= IS_NUMBER_TRAILING;
}
} else
* belong in a number at all (unless it's a radix character in a weird
* locale). Given this, it's far more likely to be a minus than the
* others. (On EBCDIC it is one of 42, 44, 46, 48, 4A, 4C, 4E, (not 40
- * because can't be a space) 60, 62, 64, 66, 68, 6A, 6C, 6E. Again, only
- * potentially a weird radix character, or 4E='+', or 60='-') */
+ * because can't be a space) 60, 62, 64, 66, 68, 6A, 6C, 6E. Again,
+ * only potentially a weird radix character, or 4E='+', or 60='-') */
if (LIKELY(*s == '-')) {
s++;
numtype = IS_NUMBER_NEG;
passing a non-NULL C<endptr>), and if the intial bytes of that portion form a
valid value, it will return TRUE, setting C<*endptr> to the byte following the
final digit of the value. But if there is no constraint at what's looked at,
-all of C<pv> must be valid in order for TRUE to be returned.
+all of C<pv> must be valid in order for TRUE to be returned. C<*endptr> is
+unchanged from its value on input if FALSE is returned;
The only characters this accepts are the decimal digits '0'..'9'.
NV
Perl_my_atof(pTHX_ const char* s)
{
- /* 's' must be NUL terminated */
+
+/*
+=for apidoc my_atof
+
+L<C<atof>(3)>, but properly works with Perl locale handling, accepting a dot
+radix character always, but also the current locale's radix character if and
+only if called from within the lexical scope of a Perl C<use locale> statement.
+
+N.B. C<s> must be NUL terminated.
+
+=cut
+*/
NV x = 0.0;
/* now apply the sign */
if (negative)
result[2] = -result[2];
-#endif /* USE_PERL_ATOF */
*value = result[2];
return (char *)s;
+#else /* USE_PERL_ATOF */
+ /* If you see this error you both don't have strtod (or configured -Ud_strtod or
+ or it's long double/quadmath equivalent) and disabled USE_PERL_ATOF, thus
+ removing any way for perl to convert strings to floating point numbers.
+ */
+# error No mechanism to convert strings to numbers available
+#endif
}
/*