- PERL_ARGS_ASSERT_SCAN_OCT;
-
- *retlen = len;
- return (flags & PERL_SCAN_GREATER_THAN_UV_MAX) ? rnv : (NV)ruv;
-}
-
-NV
-Perl_scan_hex(pTHX_ const char *start, STRLEN len, STRLEN *retlen)
-{
- NV rnv;
- I32 flags = *retlen ? PERL_SCAN_ALLOW_UNDERSCORES : 0;
- const UV ruv = grok_hex (start, &len, &flags, &rnv);
-
- PERL_ARGS_ASSERT_SCAN_HEX;
-
- *retlen = len;
- return (flags & PERL_SCAN_GREATER_THAN_UV_MAX) ? rnv : (NV)ruv;
-}
-
-/*
-=for apidoc grok_numeric_radix
-
-Scan and skip for a numeric decimal separator (radix).
-
-=cut
- */
-bool
-Perl_grok_numeric_radix(pTHX_ const char **sp, const char *send)
-{
-#ifdef USE_LOCALE_NUMERIC
- PERL_ARGS_ASSERT_GROK_NUMERIC_RADIX;
-
- if (IN_LC(LC_NUMERIC)) {
- DECLARE_STORE_LC_NUMERIC_SET_TO_NEEDED();
- if (PL_numeric_radix_sv) {
- STRLEN len;
- const char * const radix = SvPV(PL_numeric_radix_sv, len);
- if (*sp + len <= send && memEQ(*sp, radix, len)) {
- *sp += len;
- RESTORE_LC_NUMERIC();
- return TRUE;
- }
- }
- RESTORE_LC_NUMERIC();
- }
- /* always try "." if numeric radix didn't match because
- * we may have data from different locales mixed */
-#endif
-
- PERL_ARGS_ASSERT_GROK_NUMERIC_RADIX;
-
- if (*sp < send && **sp == '.') {
- ++*sp;
- return TRUE;
- }
- return FALSE;
-}
-
-/*
-=for apidoc nan_hibyte
-
-Given an NV, returns pointer to the byte containing the most
-significant bit of the NaN, this bit is most commonly the
-quiet/signaling bit of the NaN. The mask will contain a mask
-appropriate for manipulating the most significant bit.
-Note that this bit may not be the highest bit of the byte.
-
-If the NV is not a NaN, returns NULL.
-
-Most platforms have "high bit is one" -> quiet nan.
-The known opposite exceptions are older MIPS and HPPA platforms.
-
-Some platforms do not differentiate between quiet and signaling NaNs.
-
-=cut
-*/
-U8*
-Perl_nan_hibyte(NV *nvp, U8* mask)
-{
- STRLEN i = (NV_MANT_REAL_DIG - 1) / 8;
- STRLEN j = (NV_MANT_REAL_DIG - 1) % 8;
-
- PERL_ARGS_ASSERT_NAN_HIBYTE;
-
- *mask = 1 << j;
-#ifdef NV_BIG_ENDIAN
- return (U8*) nvp + NVSIZE - 1 - i;
-#endif
-#ifdef NV_LITTLE_ENDIAN
- return (U8*) nvp + i;
-#endif
-}
-
-/*
-=for apidoc nan_signaling_set
-
-Set or unset the NaN signaling-ness.
-
-Of those platforms that differentiate between quiet and signaling
-platforms the majority has the semantics of the most significant bit
-being on meaning quiet NaN, so for signaling we need to clear the bit.
-
-Some platforms (older MIPS, and HPPA) have the opposite
-semantics, and we set the bit for a signaling NaN.
-
-=cut
-*/
-void
-Perl_nan_signaling_set(pTHX_ NV *nvp, bool signaling)
-{
- U8 mask;
- U8* hibyte;
-
- PERL_ARGS_ASSERT_NAN_SIGNALING_SET;
-
- hibyte = nan_hibyte(nvp, &mask);
- if (hibyte) {
- const NV nan = NV_NAN;
- /* Decent optimizers should make the irrelevant branch to disappear. */
- if ((((U8*)&nan)[hibyte - (U8*)nvp] & mask)) {
- /* x86 style: the most significant bit of the NaN is off
- * for a signaling NaN, and on for a quiet NaN. */
- if (signaling) {
- *hibyte &= ~mask;
- } else {
- *hibyte |= mask;
- }
- } else {
- /* MIPS/HPPA style: the most significant bit of the NaN is on
- * for a signaling NaN, and off for a quiet NaN. */
- if (signaling) {
- *hibyte |= mask;
- } else {
- *hibyte &= ~mask;
- }
- }
- }
-}
-
-/*
-=for apidoc nan_is_signaling
-
-Returns true if the nv is a NaN is a signaling NaN.
-
-=cut
-*/
-int
-Perl_nan_is_signaling(NV nv)
-{
- /* Quiet NaN bit pattern (64-bit doubles, ignore endianness):
- * x86 00 00 00 00 00 00 f8 7f
- * sparc 7f ff ff ff ff ff ff ff
- * mips 7f f7 ff ff ff ff ff ff
- * hppa 7f f4 00 00 00 00 00 00
- * The "7ff" is the exponent. The most significant bit of the NaN
- * (note: here, not the most significant bit of the byte) is of
- * interest: in the x86 style (also in sparc) the bit on means
- * 'quiet', in the mips style the bit off means 'quiet'. */
-#ifdef Perl_fp_classify_snan
- return Perl_fp_classify_snan(nv);
-#else
- if (Perl_isnan(nv)) {
- U8 mask;
- U8 *hibyte = nan_hibyte(&nv, &mask);
- /* Hoping NV_NAN is a quiet nan - this might be a false hope.
- * XXX Configure test */
- const NV nan = NV_NAN;
- return (*hibyte & mask) != (((U8*)&nan)[hibyte - (U8*)&nv] & mask);
- } else {
- return 0;
- }
-#endif
-}
-
-/* The largest known floating point numbers are the IEEE quadruple
- * precision of 128 bits. */
-#define MAX_NV_BYTES (128/8)
-
-static const char nan_payload_error[] = "NaN payload error";
-
-/*
-
-=for apidoc nan_payload_set
-
-Set the NaN payload of the nv.
-
-The first byte is the highest order byte of the payload (big-endian).
-
-The signaling flag, if true, turns the generated NaN into a signaling one.
-In most platforms this means turning _off_ the most significant bit of the
-NaN. Note the _most_ - some platforms have the opposite semantics.
-Do not assume any portability of the NaN semantics.
-
-=cut
-*/
-void
-Perl_nan_payload_set(pTHX_ NV *nvp, const void *bytes, STRLEN byten, bool signaling)
-{
- /* How many bits we can set in the payload.
- *
- * Note that whether the most signicant bit is a quiet or
- * signaling NaN is actually unstandardized. Most platforms use
- * it as the 'quiet' bit. The known exceptions to this are older
- * MIPS, and HPPA.
- *
- * Yet another unstandardized area is what does the difference
- * actually mean - if it exists: some platforms do not even have
- * signaling NaNs.
- *
- * C99 nan() is supposed to generate quiet NaNs. */
- int bits = NV_MANT_REAL_DIG - 1;
-
- STRLEN i, nvi;
- bool error = FALSE;
-
- /* XXX None of this works for doubledouble platforms, or for mixendians. */
-
- PERL_ARGS_ASSERT_NAN_PAYLOAD_SET;
-
- *nvp = NV_NAN;
-
-#ifdef NV_BIG_ENDIAN
- nvi = NVSIZE - 1;
-#endif
-#ifdef NV_LITTLE_ENDIAN
- nvi = 0;
-#endif
-
- if (byten > MAX_NV_BYTES) {
- byten = MAX_NV_BYTES;
- error = TRUE;
- }
- for (i = 0; bits > 0; i++) {
- U8 b = i < byten ? ((U8*) bytes)[i] : 0;
- if (bits > 0 && bits < 8) {
- U8 m = (1 << bits) - 1;
- ((U8*)nvp)[nvi] &= ~m;
- ((U8*)nvp)[nvi] |= b & m;
- bits = 0;
- } else {
- ((U8*)nvp)[nvi] = b;
- bits -= 8;
- }
-#ifdef NV_BIG_ENDIAN
- nvi--;
-#endif
-#ifdef NV_LITTLE_ENDIAN
- nvi++;
-#endif
- }
- if (error) {
- Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
- nan_payload_error);
- }
- nan_signaling_set(nvp, signaling);
-}
-
-/*
-=for apidoc grok_nan_payload
-
-Helper for grok_nan().
-
-Parses the "..." in C99-style "nan(...)" strings, and sets the nvp accordingly.
-
-If you want the parse the "nan" part you need to use grok_nan().
-
-=cut
-*/
-const char *
-Perl_grok_nan_payload(pTHX_ const char* s, const char* send, bool signaling, int *flags, NV* nvp)
-{
- U8 bytes[MAX_NV_BYTES];
- STRLEN byten = 0;
- const char *t = send - 1; /* minus one for ')' */
- bool error = FALSE;
-
- PERL_ARGS_ASSERT_GROK_NAN_PAYLOAD;
-
- /* XXX: legacy nan payload formats like "nan123",
- * "nan0xabc", or "nan(s123)" ("s" for signaling). */
-
- while (t > s && isSPACE(*t)) t--;
- if (*t != ')') {
- return send;
- }
-
- if (++s == send) {
- *flags |= IS_NUMBER_TRAILING;
- return s;
- }
-
- while (s < t && byten < MAX_NV_BYTES) {
- UV uv;
- int nantype = 0;
-
- if (s[0] == '0' && s + 2 < t &&
- isALPHA_FOLD_EQ(s[1], 'x') &&
- isXDIGIT(s[2])) {
- const char *u = s + 3;
- STRLEN len;
- I32 uvflags;
-
- while (isXDIGIT(*u)) u++;
- len = u - s;
- uvflags = PERL_SCAN_ALLOW_UNDERSCORES;
- uv = grok_hex(s, &len, &uvflags, NULL);
- if ((uvflags & 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')) {
- const char *u = s + 3;
- STRLEN len;
- I32 uvflags;
-
- while (*u == '0' || *u == '1') u++;
- len = u - s;
- uvflags = PERL_SCAN_ALLOW_UNDERSCORES;
- uv = grok_bin(s, &len, &uvflags, NULL);
- if ((uvflags & PERL_SCAN_GREATER_THAN_UV_MAX)) {
- nantype = 0;
- } else {
- nantype = IS_NUMBER_IN_UV;
- }
- s += len;
- } else if ((s[0] == '\'' || s[0] == '"') &&
- s + 2 < t && t[-1] == s[0]) {
- /* Perl extension: if the input looks like a string
- * constant ('' or ""), read its bytes as-they-come. */
- STRLEN n = t - s - 2;
- STRLEN i;
- if ((n > MAX_NV_BYTES - byten) ||
- (n * 8 > NV_MANT_REAL_DIG)) {
- error = TRUE;
- break;
- }
- /* Copy the bytes in reverse so that \x41\x42 ('AB')
- * is equivalent to 0x4142. In other words, the bytes
- * are in big-endian order. */
- for (i = 0; i < n; i++) {
- bytes[n - i - 1] = s[i + 1];
- }
- byten += n;
- break;
- } else if (s < t && isDIGIT(*s)) {
- const char *u;
- nantype =
- grok_number_flags(s, (STRLEN)(t - s), &uv,
- 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 < send - 1; u++) {
- if (!isDIGIT(*u)) {
- *flags |= IS_NUMBER_TRAILING;
- break;
- }
- }
- s = u;
- } else {
- error = TRUE;
- break;
- }
- /* XXX Doesn't do octal: nan("0123").
- * Probably not a big loss. */
-
- if (!(nantype & IS_NUMBER_IN_UV)) {
- error = TRUE;
- break;
- }
-
- if (uv) {
- while (uv && byten < MAX_NV_BYTES) {
- bytes[byten++] = (U8) (uv & 0xFF);
- uv >>= 8;
- }
- }
- }
-
- if (byten == 0) {
- bytes[byten++] = 0;
- }
-
- if (error) {
- Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
- nan_payload_error);
- }
-
- if (s == send) {
- *flags |= IS_NUMBER_TRAILING;
- return s;
- }
-
- if (nvp) {
- nan_payload_set(nvp, bytes, byten, signaling);
- }
https://perl5.git.perl.org / perl5.git / blobdiff