Skip to content

Commit

Permalink
Merge adeb727 into 5fe711c
Browse files Browse the repository at this point in the history
  • Loading branch information
@hvds
hvds committed Sep 18, 2021
2 parents 5fe711c + adeb727 commit e00d574
Show file tree
Hide file tree
Showing 2 changed files with 91 additions and 85 deletions.
17 changes: 10 additions & 7 deletions ext/XS-APItest/t/grok.t
View file
Expand Up @@ -86,14 +86,17 @@ my @groks =
[ "Inf", 0, undef,
IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT ],
[ "In", 0, undef, 0 ],
[ "Infin",0, undef, IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT | IS_NUMBER_TRAILING ],
# this doesn't work and hasn't been needed yet
#[ "Infin",PERL_SCAN_TRAILING, undef,
# IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT | IS_NUMBER_TRAILING ],
[ "Infin",0, undef, 0 ],
[ "Infin",PERL_SCAN_TRAILING, undef,
IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT | IS_NUMBER_TRAILING ],
[ "nan", 0, undef, IS_NUMBER_NAN | IS_NUMBER_NOT_INT ],
# even without PERL_SCAN_TRAILING nan can have weird stuff trailing
[ "nanx", 0, undef, IS_NUMBER_NAN | IS_NUMBER_NOT_INT | IS_NUMBER_TRAILING ],
[ "nanx", PERL_SCAN_TRAILING, undef, IS_NUMBER_NAN | IS_NUMBER_NOT_INT | IS_NUMBER_TRAILING ],
# even without PERL_SCAN_TRAILING nan can have specific weird stuff trailing
[ "nanq", 0, undef, IS_NUMBER_NAN | IS_NUMBER_NOT_INT ],
[ "nan(123)", 0, undef, IS_NUMBER_NAN | IS_NUMBER_NOT_INT ],
# but not just anything
[ "nanx", 0, undef, 0 ],
[ "nanx", PERL_SCAN_TRAILING, undef,
IS_NUMBER_NAN | IS_NUMBER_NOT_INT | IS_NUMBER_TRAILING ],
);

my $non_ieee_fp = ($Config{doublekind} == 9 ||
Expand Down
159 changes: 81 additions & 78 deletions numeric.c
View file
Expand Up @@ -771,36 +771,33 @@ Perl_grok_infnan(pTHX_ const char** sp, const char* send)
s++; if (s == send || isALPHA_FOLD_NE(*s, 'N')) return 0;
s++; if (s == send) return 0;
if (isALPHA_FOLD_EQ(*s, 'F')) {
s++;
flags |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT;
*sp = ++s;
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++;
int trail = flags | IS_NUMBER_TRAILING;
s++; if (s == send || isALPHA_FOLD_NE(*s, 'N')) return trail;
s++; if (s == send || isALPHA_FOLD_NE(*s, 'I')) return trail;
s++; if (s == send || isALPHA_FOLD_NE(*s, 'T')) return trail;
s++; if (s == send || isALPHA_FOLD_NE(*s, 'Y')) return trail;
*sp = ++s;
} else if (odh) {
while (s < send && *s == '0') { /* 1.#INF00 */
s++;
}
}
while (s < send && isSPACE(*s))
s++;
if (s < send && *s) {
flags |= IS_NUMBER_TRAILING;
}
flags |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT;
*sp = s;
return flags | (s < send ? IS_NUMBER_TRAILING : 0);
}
else if (isALPHA_FOLD_EQ(*s, 'D') && odh) { /* 1.#IND */
s++;
flags |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT;
while (s < send && *s == '0') { /* 1.#IND00 */
s++;
}
if (s < send && *s) {
flags |= IS_NUMBER_TRAILING;
}
*sp = s;
return flags | (s < send ? IS_NUMBER_TRAILING : 0);
} else
return 0;
}
Expand All @@ -816,9 +813,9 @@ Perl_grok_infnan(pTHX_ const char** sp, const char* send)
if (isALPHA_FOLD_EQ(*s, 'N')) {
s++; if (s == send || isALPHA_FOLD_NE(*s, 'A')) return 0;
s++; if (s == send || isALPHA_FOLD_NE(*s, 'N')) return 0;
s++;

flags |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT;
*sp = ++s;

if (s == send) {
return flags;
}
Expand All @@ -832,25 +829,22 @@ Perl_grok_infnan(pTHX_ const char** sp, const char* send)
isALPHA_FOLD_EQ(*s, 's')) {
/* "nanq" or "nans" are ok, though generating
* these portably is tricky. */
s++;
*sp = ++s;
if (s == send) {
return flags;
}
}
if (*s == '(') {
/* C99 style "nan(123)" or Perlish equivalent "nan($uv)". */
const char *t;
int trail = flags | IS_NUMBER_TRAILING;
s++;
if (s == send) {
return flags | IS_NUMBER_TRAILING;
}
if (s == send) { return trail; }
t = s + 1;
while (t < send && *t && *t != ')') {
t++;
}
if (t == send) {
return flags | IS_NUMBER_TRAILING;
}
if (t == send) { return trail; }
if (*t == ')') {
int nantype;
UV nanval;
Expand Down Expand Up @@ -900,80 +894,78 @@ Perl_grok_infnan(pTHX_ const char** sp, const char* send)
/* XXX Doesn't do octal: nan("0123").
* Probably not a big loss. */

/* 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 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. The endianness
* of UVs and NVs can be different. */

if ((nantype & IS_NUMBER_NOT_INT) ||
!(nantype && IS_NUMBER_IN_UV)) {
/* 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 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. The endianness
* of UVs and NVs can be different. */
return 0;
/* treat "NaN(invalid)" the same as "NaNgarbage" */
return trail;
}
if (s < t) {
flags |= IS_NUMBER_TRAILING;
else {
*sp = t + 1;
return (s + 1 < t || t + 1 < send) ? trail : flags;
}
} else {
/* Looked like nan(...), but no close paren. */
flags |= IS_NUMBER_TRAILING;
return trail;
}
} else {
while (s < send && isSPACE(*s))
s++;
if (s < send && *s) {
/* Note that we here implicitly accept (parse as
* "nan", but with warnings) also any other weird
* trailing stuff for "nan". In the above we just
* check that if we got the C99-style "nan(...)",
* the "..." looks sane.
* If in future we accept more ways of specifying
* the nan payload, the accepting would happen around
* here. */
flags |= IS_NUMBER_TRAILING;
}
/* Note that we here implicitly accept (parse as
* "nan", but with warnings) also any other weird
* trailing stuff for "nan". In the above we just
* check that if we got the C99-style "nan(...)",
* the "..." looks sane.
* If in future we accept more ways of specifying
* the nan payload, the accepting would happen around
* here. */
*sp = s;
return flags | (s < send ? IS_NUMBER_TRAILING : 0);
}
s = send;
}
else
return 0;
}

while (s < send && isSPACE(*s))
s++;

#else
PERL_UNUSED_ARG(send);
#endif /* #if defined(NV_INF) || defined(NV_NAN) */
*sp = s;
return flags;
#endif /* #if defined(NV_INF) || defined(NV_NAN) */
}

/*
Expand Down Expand Up @@ -1245,6 +1237,10 @@ Perl_grok_number_flags(pTHX_ const char *pv, STRLEN len, UV *valuep, U32 flags)
/* Really detect inf/nan. Start at d, not s, since the above
* code might have already consumed the "1." or "1". */
const int infnan = Perl_grok_infnan(aTHX_ &d, send);

if ((infnan & IS_NUMBER_TRAILING) && !(flags & PERL_SCAN_TRAILING)) {
return 0;
}
if ((infnan & IS_NUMBER_INFINITY)) {
return (numtype | infnan); /* Keep sign for infinity. */
}
Expand Down Expand Up @@ -1536,6 +1532,9 @@ 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;
const int infnan = grok_infnan(&p, send);
/* We act like PERL_SCAN_TRAILING here to permit trailing garbage,
* it is not clear if that is desirable.
*/
if (infnan && p != p0) {
/* If we can generate inf/nan directly, let's do so. */
#ifdef NV_INF
Expand Down Expand Up @@ -1889,6 +1888,10 @@ Checks whether the argument would be either an infinity or C<NaN> when used
as a number, but is careful not to trigger non-numeric or uninitialized
warnings. it assumes the caller has done C<SvGETMAGIC(sv)> already.
Note that this always accepts trailing garbage (similar to C<grok_number_flags>
with C<PERL_SCAN_TRAILING>), so C<"inferior"> and C<"NAND gates"> will
return true.
=cut
*/

Expand Down

0 comments on commit e00d574

Please sign in to comment.