converts a string representing a binary number to numeric form.
-On entry I<start> and I<*len> give the string to scan, I<*flags> gives
-conversion flags, and I<result> should be NULL or a pointer to an NV.
+On entry C<start> and C<*len> give the string to scan, C<*flags> gives
+conversion flags, and C<result> should be NULL or a pointer to an NV.
The scan stops at the end of the string, or the first invalid character.
-Unless C<PERL_SCAN_SILENT_ILLDIGIT> is set in I<*flags>, encountering an
+Unless C<PERL_SCAN_SILENT_ILLDIGIT> is set in C<*flags>, encountering an
invalid character will also trigger a warning.
-On return I<*len> is set to the length of the scanned string,
-and I<*flags> gives output flags.
+On return C<*len> is set to the length of the scanned string,
+and C<*flags> gives output flags.
If the value is <= C<UV_MAX> it is returned as a UV, the output flags are clear,
-and nothing is written to I<*result>. If the value is > UV_MAX C<grok_bin>
+and nothing is written to C<*result>. If the value is > UV_MAX C<grok_bin>
returns UV_MAX, sets C<PERL_SCAN_GREATER_THAN_UV_MAX> in the output flags,
-and writes the value to I<*result> (or the value is discarded if I<result>
+and writes the value to C<*result> (or the value is discarded if C<result>
is NULL).
The binary number may optionally be prefixed with "0b" or "b" unless
-C<PERL_SCAN_DISALLOW_PREFIX> is set in I<*flags> on entry. If
-C<PERL_SCAN_ALLOW_UNDERSCORES> is set in I<*flags> then the binary
+C<PERL_SCAN_DISALLOW_PREFIX> is set in C<*flags> on entry. If
+C<PERL_SCAN_ALLOW_UNDERSCORES> is set in C<*flags> then the binary
number may use '_' characters to separate digits.
=cut
converts a string representing a hex number to numeric form.
-On entry I<start> and I<*len_p> give the string to scan, I<*flags> gives
-conversion flags, and I<result> should be NULL or a pointer to an NV.
+On entry C<start> and C<*len_p> give the string to scan, C<*flags> gives
+conversion flags, and C<result> should be NULL or a pointer to an NV.
The scan stops at the end of the string, or the first invalid character.
-Unless C<PERL_SCAN_SILENT_ILLDIGIT> is set in I<*flags>, encountering an
+Unless C<PERL_SCAN_SILENT_ILLDIGIT> is set in C<*flags>, encountering an
invalid character will also trigger a warning.
-On return I<*len> is set to the length of the scanned string,
-and I<*flags> gives output flags.
+On return C<*len> is set to the length of the scanned string,
+and C<*flags> gives output flags.
If the value is <= UV_MAX it is returned as a UV, the output flags are clear,
-and nothing is written to I<*result>. If the value is > UV_MAX C<grok_hex>
+and nothing is written to C<*result>. If the value is > UV_MAX C<grok_hex>
returns UV_MAX, sets C<PERL_SCAN_GREATER_THAN_UV_MAX> in the output flags,
-and writes the value to I<*result> (or the value is discarded if I<result>
+and writes the value to C<*result> (or the value is discarded if C<result>
is NULL).
The hex number may optionally be prefixed with "0x" or "x" unless
-C<PERL_SCAN_DISALLOW_PREFIX> is set in I<*flags> on entry. If
-C<PERL_SCAN_ALLOW_UNDERSCORES> is set in I<*flags> then the hex
+C<PERL_SCAN_DISALLOW_PREFIX> is set in C<*flags> on entry. If
+C<PERL_SCAN_ALLOW_UNDERSCORES> is set in C<*flags> then the hex
number may use '_' characters to separate digits.
=cut
converts a string representing an octal number to numeric form.
-On entry I<start> and I<*len> give the string to scan, I<*flags> gives
-conversion flags, and I<result> should be NULL or a pointer to an NV.
+On entry C<start> and C<*len> give the string to scan, C<*flags> gives
+conversion flags, and C<result> should be NULL or a pointer to an NV.
The scan stops at the end of the string, or the first invalid character.
-Unless C<PERL_SCAN_SILENT_ILLDIGIT> is set in I<*flags>, encountering an
+Unless C<PERL_SCAN_SILENT_ILLDIGIT> is set in C<*flags>, encountering an
8 or 9 will also trigger a warning.
-On return I<*len> is set to the length of the scanned string,
-and I<*flags> gives output flags.
+On return C<*len> is set to the length of the scanned string,
+and C<*flags> gives output flags.
If the value is <= UV_MAX it is returned as a UV, the output flags are clear,
-and nothing is written to I<*result>. If the value is > UV_MAX C<grok_oct>
+and nothing is written to C<*result>. If the value is > UV_MAX C<grok_oct>
returns UV_MAX, sets C<PERL_SCAN_GREATER_THAN_UV_MAX> in the output flags,
-and writes the value to I<*result> (or the value is discarded if I<result>
+and writes the value to C<*result> (or the value is discarded if C<result>
is NULL).
-If C<PERL_SCAN_ALLOW_UNDERSCORES> is set in I<*flags> then the octal
+If C<PERL_SCAN_ALLOW_UNDERSCORES> is set in C<*flags> then the octal
number may use '_' characters to separate digits.
=cut
PERL_ARGS_ASSERT_GROK_NUMERIC_RADIX;
if (IN_LC(LC_NUMERIC)) {
- DECLARE_STORE_LC_NUMERIC_SET_TO_NEEDED();
+ DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
+ STORE_LC_NUMERIC_SET_TO_NEEDED();
if (PL_numeric_radix_sv) {
STRLEN len;
const char * const radix = SvPV(PL_numeric_radix_sv, len);
}
/*
-=for apidoc grok_number_flags
-
-Recognise (or not) a number. The type of the number is returned
-(0 if unrecognised), otherwise it is a bit-ORed combination of
-IS_NUMBER_IN_UV, IS_NUMBER_GREATER_THAN_UV_MAX, IS_NUMBER_NOT_INT,
-IS_NUMBER_NEG, IS_NUMBER_INFINITY, IS_NUMBER_NAN (defined in perl.h).
-
-If the value of the number can fit in a UV, it is returned in the *valuep
-IS_NUMBER_IN_UV will be set to indicate that *valuep is valid, IS_NUMBER_IN_UV
-will never be set unless *valuep is valid, but *valuep may have been assigned
-to during processing even though IS_NUMBER_IN_UV is not set on return.
-If valuep is NULL, IS_NUMBER_IN_UV will be set for the same cases as when
-valuep is non-NULL, but no actual assignment (or SEGV) will occur.
-
-IS_NUMBER_NOT_INT will be set with IS_NUMBER_IN_UV if trailing decimals were
-seen (in which case *valuep gives the true value truncated to an integer), and
-IS_NUMBER_NEG if the number is negative (in which case *valuep holds the
-absolute value). IS_NUMBER_IN_UV is not set if e notation was used or the
-number is larger than a UV.
-
-C<flags> allows only C<PERL_SCAN_TRAILING>, which allows for trailing
-non-numeric text on an otherwise successful I<grok>, setting
-C<IS_NUMBER_TRAILING> on the result.
-
-=for apidoc grok_number
-
-Identical to grok_number_flags() with flags set to zero.
-
-=cut
- */
-int
-Perl_grok_number(pTHX_ const char *pv, STRLEN len, UV *valuep)
-{
- PERL_ARGS_ASSERT_GROK_NUMBER;
-
- return grok_number_flags(pv, len, valuep, 0);
-}
-
-/*
=for apidoc grok_infnan
Helper for grok_number(), accepts various ways of spelling "infinity"
IS_NUMBER_NAN | IS_NUMBER_NEG
0
-possibly with IS_NUMBER_TRAILING.
+possibly |-ed with IS_NUMBER_TRAILING.
-If an infinity or not-a-number is recognized, the *sp will point to
-one past the end of the recognized string. If the recognition fails,
+If an infinity or a not-a-number is recognized, the *sp will point to
+one byte past the end of the recognized string. If the recognition fails,
zero is returned, and the *sp will not move.
=cut
*/
int
-Perl_grok_infnan(const char** sp, const char* send)
+Perl_grok_infnan(pTHX_ const char** sp, const char* send)
{
const char* s = *sp;
int flags = 0;
- bool odh = FALSE; /* one dot hash: 1.#INF */
+ bool odh = FALSE; /* one-dot-hash: 1.#INF */
PERL_ARGS_ASSERT_GROK_INFNAN;
}
if (*s == '1') {
- /* Visual C: 1.#SNAN, -1.#QNAN, 1#INF, 1#.IND (maybe also 1.#NAN) */
+ /* Visual C: 1.#SNAN, -1.#QNAN, 1#INF, 1.#IND (maybe also 1.#NAN)
+ * Let's keep the dot optional. */
s++; if (s == send) return 0;
if (*s == '.') {
s++; if (s == send) return 0;
}
if (isALPHA_FOLD_EQ(*s, 'I')) {
- /* INF or IND (1.#IND is indeterminate, a certain type of NAN) */
+ /* INF or IND (1.#IND is "indeterminate", a certain type of NAN) */
+
s++; if (s == send || isALPHA_FOLD_NE(*s, 'N')) return 0;
s++; if (s == send) return 0;
if (isALPHA_FOLD_EQ(*s, 'F')) {
s++;
- while (*s == '0') { /* 1.#INF00 */
+ if (s < send && (isALPHA_FOLD_EQ(*s, 'I'))) {
+ int fail =
+ flags | IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT | IS_NUMBER_TRAILING;
+ s++; if (s == send || isALPHA_FOLD_NE(*s, 'N')) return fail;
+ s++; if (s == send || isALPHA_FOLD_NE(*s, 'I')) return fail;
+ s++; if (s == send || isALPHA_FOLD_NE(*s, 'T')) return fail;
+ s++; if (s == send || isALPHA_FOLD_NE(*s, 'Y')) return fail;
s++;
+ } else if (odh) {
+ while (*s == '0') { /* 1.#INF00 */
+ s++;
+ }
}
while (s < send && isSPACE(*s))
s++;
return 0;
}
else {
- /* NAN */
+ /* Maybe NAN of some sort */
+
if (isALPHA_FOLD_EQ(*s, 'S') || isALPHA_FOLD_EQ(*s, 'Q')) {
/* snan, qNaN */
/* XXX do something with the snan/qnan difference */
if (*s == '(') {
/* C99 style "nan(123)" or Perlish equivalent "nan($uv)". */
const char *t;
- UV nanval;
s++;
if (s == send) {
return flags | IS_NUMBER_TRAILING;
return flags | IS_NUMBER_TRAILING;
}
if (*t == ')') {
- int nantype =
- grok_number_flags(s, t - s, &nanval,
- PERL_SCAN_TRAILING |
- PERL_SCAN_ALLOW_UNDERSCORES);
- /* nanval result currently unused */
+ int nantype;
+ UV nanval;
+ if (s[0] == '0' && s + 2 < t &&
+ isALPHA_FOLD_EQ(s[1], 'x') &&
+ isXDIGIT(s[2])) {
+ STRLEN len = t - s;
+ I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
+ nanval = grok_hex(s, &len, &flags, NULL);
+ if ((flags & PERL_SCAN_GREATER_THAN_UV_MAX)) {
+ nantype = 0;
+ } else {
+ nantype = IS_NUMBER_IN_UV;
+ }
+ s += len;
+ } else if (s[0] == '0' && s + 2 < t &&
+ isALPHA_FOLD_EQ(s[1], 'b') &&
+ (s[2] == '0' || s[2] == '1')) {
+ STRLEN len = t - s;
+ I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
+ nanval = grok_bin(s, &len, &flags, NULL);
+ if ((flags & PERL_SCAN_GREATER_THAN_UV_MAX)) {
+ nantype = 0;
+ } else {
+ nantype = IS_NUMBER_IN_UV;
+ }
+ s += len;
+ } else {
+ const char *u;
+ nantype =
+ grok_number_flags(s, t - s, &nanval,
+ PERL_SCAN_TRAILING |
+ PERL_SCAN_ALLOW_UNDERSCORES);
+ /* Unfortunately grok_number_flags() doesn't
+ * tell how far we got and the ')' will always
+ * be "trailing", so we need to double-check
+ * whether we had something dubious. */
+ for (u = s; u < t; u++) {
+ if (!isDIGIT(*u)) {
+ flags |= IS_NUMBER_TRAILING;
+ break;
+ }
+ }
+ s = u;
+ }
+
+ /* XXX Doesn't do octal: nan("0123").
+ * Probably not a big loss. */
+
if ((nantype & IS_NUMBER_NOT_INT) ||
!(nantype && IS_NUMBER_IN_UV)) {
- /* Certain configuration combinations where
- * NVSIZE is greater than UVSIZE mean that a
- * single UV cannot contain all the possible
+ /* XXX the nanval is currently unused, that is,
+ * not inserted as the NaN payload of the NV.
+ * But the above code already parses the C99
+ * nan(...) format. See below, and see also
+ * the nan() in POSIX.xs.
+ *
+ * Certain configuration combinations where
+ * NVSIZE is greater than UVSIZE mean that
+ * a single UV cannot contain all the possible
* NaN payload bits. There would need to be
* some more generic syntax than "nan($uv)".
+ *
* Issues to keep in mind:
+ *
* (1) In most common cases there would
* not be an integral number of bytes that
* could be set, only a certain number of bits.
- * For example for NVSIZE==UVSIZE there can be
- * up to 52 bits in the payload, but one bit is
- * commonly reserved for the signal/quiet bit,
- * so 51 bits.
+ * For example for the common case of
+ * NVSIZE == UVSIZE == 8 there is room for 52
+ * bits in the payload, but the most significant
+ * bit is commonly reserved for the
+ * signaling/quiet bit, leaving 51 bits.
+ * Furthermore, the C99 nan() is supposed
+ * to generate quiet NaNs, so it is doubtful
+ * whether it should be able to generate
+ * signaling NaNs. For the x86 80-bit doubles
+ * (if building a long double Perl) there would
+ * be 62 bits (s/q bit being the 63rd).
+ *
* (2) Endianness of the payload bits. If the
* payload is specified as an UV, the low-order
* bits of the UV are naturally little-endianed
- * (rightmost) bits of the payload. */
+ * (rightmost) bits of the payload. The endianness
+ * of UVs and NVs can be different. */
return 0;
}
- /* Unfortunately the grok_ interfaces don't tell
- * the count of the consumed bytes, so we cannot
- * figure out where the scanning left off.
- * So we need to duplicate the basics of
- * the scan ourselves. */
- if (s[0] == '0' && s < t &&
- isALPHA_FOLD_EQ(s[1], 'x')) {
- const char *u = s + 2;
- if (isXDIGIT(*u)) {
- while (u < t &&
- (isXDIGIT(*u) || *u == '_')) {
- u++;
- }
- }
- s = u;
- } else if (isDIGIT(*s) && s < t) {
- const char *u = s + 2;
- while (u < t &&
- (isDIGIT(*u) || *u == '_')) {
- u++;
- }
- s = u;
- }
- /* XXX 0b... maybe, octal (really?) */
if (s < t) {
flags |= IS_NUMBER_TRAILING;
}
return flags;
}
+/*
+=for apidoc grok_number_flags
+
+Recognise (or not) a number. The type of the number is returned
+(0 if unrecognised), otherwise it is a bit-ORed combination of
+IS_NUMBER_IN_UV, IS_NUMBER_GREATER_THAN_UV_MAX, IS_NUMBER_NOT_INT,
+IS_NUMBER_NEG, IS_NUMBER_INFINITY, IS_NUMBER_NAN (defined in perl.h).
+
+If the value of the number can fit in a UV, it is returned in the *valuep
+IS_NUMBER_IN_UV will be set to indicate that *valuep is valid, IS_NUMBER_IN_UV
+will never be set unless *valuep is valid, but *valuep may have been assigned
+to during processing even though IS_NUMBER_IN_UV is not set on return.
+If valuep is NULL, IS_NUMBER_IN_UV will be set for the same cases as when
+valuep is non-NULL, but no actual assignment (or SEGV) will occur.
+
+IS_NUMBER_NOT_INT will be set with IS_NUMBER_IN_UV if trailing decimals were
+seen (in which case *valuep gives the true value truncated to an integer), and
+IS_NUMBER_NEG if the number is negative (in which case *valuep holds the
+absolute value). IS_NUMBER_IN_UV is not set if e notation was used or the
+number is larger than a UV.
+
+C<flags> allows only C<PERL_SCAN_TRAILING>, which allows for trailing
+non-numeric text on an otherwise successful I<grok>, setting
+C<IS_NUMBER_TRAILING> on the result.
+
+=for apidoc grok_number
+
+Identical to grok_number_flags() with flags set to zero.
+
+=cut
+ */
+int
+Perl_grok_number(pTHX_ const char *pv, STRLEN len, UV *valuep)
+{
+ PERL_ARGS_ASSERT_GROK_NUMBER;
+
+ return grok_number_flags(pv, len, valuep, 0);
+}
+
static const UV uv_max_div_10 = UV_MAX / 10;
static const U8 uv_max_mod_10 = UV_MAX % 10;
if ((s + 2 < send) && strchr("inqs#", toFOLD(*s))) {
/* Really detect inf/nan. Start at d, not s, since the above
* code might have already consumed the "1." or "1". */
- int infnan = Perl_grok_infnan(&d, send);
+ int infnan = Perl_grok_infnan(aTHX_ &d, send);
if ((infnan & IS_NUMBER_INFINITY)) {
return (numtype | infnan); /* Keep sign for infinity. */
}
}
/*
-=for apidoc grok_atou
-
-grok_atou is a safer replacement for atoi and strtol.
+grok_atoUV
-grok_atou parses a C-style zero-byte terminated string, looking for
+grok_atoUV parses a C-style zero-byte terminated string, looking for
a decimal unsigned integer.
Returns the unsigned integer, if a valid value can be parsed
Accepts only the decimal digits '0'..'9'.
-As opposed to atoi or strtol, grok_atou does NOT allow optional
+As opposed to atoi or strtol, grok_atoUV does NOT allow optional
leading whitespace, or negative inputs. If such features are
required, the calling code needs to explicitly implement those.
-If a valid value cannot be parsed, returns either zero (if non-digits
-are met before any digits) or UV_MAX (if the value overflows).
-
-Note that extraneous leading zeros also count as an overflow
-(meaning that only "0" is the zero).
+Returns true if a valid value could be parsed. In that case, valptr
+is set to the parsed value, and endptr (if provided) is set to point
+to the character after the last digit.
-On failure, the *endptr is also set to NULL, unless endptr is NULL.
-
-Trailing non-digit bytes are allowed if the endptr is non-NULL.
-On return the *endptr will contain the pointer to the first non-digit byte.
-
-If the endptr is NULL, the first non-digit byte MUST be
-the zero byte terminating the pv, or zero will be returned.
+Returns false otherwise. This can happen if a) there is a leading zero
+followed by another digit; b) the digits would overflow a UV; or c)
+there are trailing non-digits AND endptr is not provided.
Background: atoi has severe problems with illegal inputs, it cannot be
used for incremental parsing, and therefore should be avoided
atoi and strtol are also affected by locale settings, which can also be
seen as a bug (global state controlled by user environment).
-=cut
*/
-UV
-Perl_grok_atou(const char *pv, const char** endptr)
+bool
+Perl_grok_atoUV(const char *pv, UV *valptr, const char** endptr)
{
const char* s = pv;
const char** eptr;
const char* end2; /* Used in case endptr is NULL. */
- UV val = 0; /* The return value. */
+ UV val = 0; /* The parsed value. */
- PERL_ARGS_ASSERT_GROK_ATOU;
+ PERL_ARGS_ASSERT_GROK_ATOUV;
eptr = endptr ? endptr : &end2;
if (isDIGIT(*s)) {
/* Single-digit inputs are quite common. */
val = *s++ - '0';
if (isDIGIT(*s)) {
- /* Extra leading zeros cause overflow. */
- if (val == 0) {
- *eptr = NULL;
- return UV_MAX;
- }
+ /* Fail on extra leading zeros. */
+ if (val == 0)
+ return FALSE;
while (isDIGIT(*s)) {
/* This could be unrolled like in grok_number(), but
* the expected uses of this are not speed-needy, and
(val == uv_max_div_10 && digit <= uv_max_mod_10)) {
val = val * 10 + digit;
} else {
- *eptr = NULL;
- return UV_MAX;
+ return FALSE;
}
}
}
}
- if (s == pv) {
- *eptr = NULL; /* If no progress, failed to parse anything. */
- return 0;
- }
- if (endptr == NULL && *s) {
- return 0; /* If endptr is NULL, no trailing non-digits allowed. */
- }
+ if (s == pv)
+ return FALSE;
+ if (endptr == NULL && *s)
+ return FALSE; /* If endptr is NULL, no trailing non-digits allowed. */
*eptr = s;
- return val;
+ *valptr = val;
+ return TRUE;
}
#ifndef USE_QUADMATH
PERL_ARGS_ASSERT_MY_ATOF;
{
- DECLARE_STORE_LC_NUMERIC_SET_TO_NEEDED();
+ DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
+ STORE_LC_NUMERIC_SET_TO_NEEDED();
if (PL_numeric_radix_sv && IN_LC(LC_NUMERIC)) {
const char *standard = NULL, *local = NULL;
bool use_standard_radix;
Perl_atof2(s, x);
if (use_standard_radix)
- SET_NUMERIC_LOCAL();
+ SET_NUMERIC_UNDERLYING();
}
else
Perl_atof2(s, x);
return x;
}
+
+#ifdef USING_MSVC6
+# pragma warning(push)
+# pragma warning(disable:4756;disable:4056)
+#endif
static char*
-S_my_atof_infnan(const char* s, bool negative, const char* send, NV* value)
+S_my_atof_infnan(pTHX_ const char* s, bool negative, const char* send, NV* value)
{
const char *p0 = negative ? s - 1 : s;
const char *p = p0;
}
return NULL;
}
+#ifdef USING_MSVC6
+# pragma warning(pop)
+#endif
char*
Perl_my_atof2(pTHX_ const char* orig, NV* value)
#ifdef USE_QUADMATH
{
char* endp;
- if ((endp = S_my_atof_infnan(s, negative, send, value)))
+ if ((endp = S_my_atof_infnan(aTHX_ s, negative, send, value)))
return endp;
result[2] = strtoflt128(s, &endp);
if (s != endp) {
{
const char* endp;
- if ((endp = S_my_atof_infnan(s, negative, send, value)))
+ if ((endp = S_my_atof_infnan(aTHX_ s, negative, send, value)))
return (char*)endp;
}
#endif
/*
- * Local variables:
- * c-indentation-style: bsd
- * c-basic-offset: 4
- * indent-tabs-mode: nil
- * End:
- *
* ex: set ts=8 sts=4 sw=4 et:
*/
https://perl5.git.perl.org / perl5.git / blobdiff