[perl5.git] / numeric.c

/*    numeric.c
 *
 *    Copyright (c) 2001, Larry Wall
 *
 *    You may distribute under the terms of either the GNU General Public
 *    License or the Artistic License, as specified in the README file.
 *
 */

/*
 * "That only makes eleven (plus one mislaid) and not fourteen, unless
 * wizards count differently to other people."
 */

#include "EXTERN.h"
#define PERL_IN_NUMERIC_C
#include "perl.h"

U32
Perl_cast_ulong(pTHX_ NV f)
{
  if (f < 0.0)
    return f < I32_MIN ? (U32) I32_MIN : (U32)(I32) f;
  if (f < U32_MAX_P1) {
#if CASTFLAGS & 2
    if (f < U32_MAX_P1_HALF)
      return (U32) f;
    f -= U32_MAX_P1_HALF;
    return ((U32) f) | (1 + U32_MAX >> 1);
#else
    return (U32) f;
#endif
  }
  return f > 0 ? U32_MAX : 0 /* NaN */;
}

I32
Perl_cast_i32(pTHX_ NV f)
{
  if (f < I32_MAX_P1)
    return f < I32_MIN ? I32_MIN : (I32) f;
  if (f < U32_MAX_P1) {
#if CASTFLAGS & 2
    if (f < U32_MAX_P1_HALF)
      return (I32)(U32) f;
    f -= U32_MAX_P1_HALF;
    return (I32)(((U32) f) | (1 + U32_MAX >> 1));
#else
    return (I32)(U32) f;
#endif
  }
  return f > 0 ? (I32)U32_MAX : 0 /* NaN */;
}

IV
Perl_cast_iv(pTHX_ NV f)
{
  if (f < IV_MAX_P1)
    return f < IV_MIN ? IV_MIN : (IV) f;
  if (f < UV_MAX_P1) {
#if CASTFLAGS & 2
    /* For future flexibility allowing for sizeof(UV) >= sizeof(IV)  */
    if (f < UV_MAX_P1_HALF)
      return (IV)(UV) f;
    f -= UV_MAX_P1_HALF;
    return (IV)(((UV) f) | (1 + UV_MAX >> 1));
#else
    return (IV)(UV) f;
#endif
  }
  return f > 0 ? (IV)UV_MAX : 0 /* NaN */;
}

UV
Perl_cast_uv(pTHX_ NV f)
{
  if (f < 0.0)
    return f < IV_MIN ? (UV) IV_MIN : (UV)(IV) f;
  if (f < UV_MAX_P1) {
#if CASTFLAGS & 2
    if (f < UV_MAX_P1_HALF)
      return (UV) f;
    f -= UV_MAX_P1_HALF;
    return ((UV) f) | (1 + UV_MAX >> 1);
#else
    return (UV) f;
#endif
  }
  return f > 0 ? UV_MAX : 0 /* NaN */;
}

#if defined(HUGE_VAL) || (defined(USE_LONG_DOUBLE) && defined(HUGE_VALL))
/*
 * This hack is to force load of "huge" support from libm.a
 * So it is in perl for (say) POSIX to use.
 * Needed for SunOS with Sun's 'acc' for example.
 */
NV
Perl_huge(void)
{
#   if defined(USE_LONG_DOUBLE) && defined(HUGE_VALL)
    return HUGE_VALL;
#   endif
    return HUGE_VAL;
}
#endif

NV
Perl_scan_bin(pTHX_ char *start, STRLEN len, STRLEN *retlen)
{
    register char *s = start;
    register NV rnv = 0.0;
    register UV ruv = 0;
    register bool seenb = FALSE;
    register bool overflowed = FALSE;

    for (; len-- && *s; s++) {
	if (!(*s == '0' || *s == '1')) {
	    if (*s == '_' && len && *retlen
		&& (s[1] == '0' || s[1] == '1'))
	    {
		--len;
		++s;
	    }
	    else if (seenb == FALSE && *s == 'b' && ruv == 0) {
		/* Disallow 0bbb0b0bbb... */
		seenb = TRUE;
		continue;
	    }
	    else {
		if (ckWARN(WARN_DIGIT))
		    Perl_warner(aTHX_ WARN_DIGIT,
				"Illegal binary digit '%c' ignored", *s);
		break;
	    }
	}
	if (!overflowed) {
	    register UV xuv = ruv << 1;

	    if ((xuv >> 1) != ruv) {
		overflowed = TRUE;
		rnv = (NV) ruv;
		if (ckWARN_d(WARN_OVERFLOW))
		    Perl_warner(aTHX_ WARN_OVERFLOW,
				"Integer overflow in binary number");
	    }
	    else
		ruv = xuv | (*s - '0');
	}
	if (overflowed) {
	    rnv *= 2;
	    /* If an NV has not enough bits in its mantissa to
	     * represent an UV this summing of small low-order numbers
	     * is a waste of time (because the NV cannot preserve
	     * the low-order bits anyway): we could just remember when
	     * did we overflow and in the end just multiply rnv by the
	     * right amount. */
	    rnv += (*s - '0');
	}
    }
    if (!overflowed)
	rnv = (NV) ruv;
    if (   ( overflowed && rnv > 4294967295.0)
#if UVSIZE > 4
	|| (!overflowed && ruv > 0xffffffff  )
#endif
	) {
	if (ckWARN(WARN_PORTABLE))
	    Perl_warner(aTHX_ WARN_PORTABLE,
			"Binary number > 0b11111111111111111111111111111111 non-portable");
    }
    *retlen = s - start;
    return rnv;
}

NV
Perl_scan_oct(pTHX_ char *start, STRLEN len, STRLEN *retlen)
{
    register char *s = start;
    register NV rnv = 0.0;
    register UV ruv = 0;
    register bool overflowed = FALSE;

    for (; len-- && *s; s++) {
	if (!(*s >= '0' && *s <= '7')) {
	    if (*s == '_' && len && *retlen
		&& (s[1] >= '0' && s[1] <= '7'))
	    {
		--len;
		++s;
	    }
	    else {
		/* Allow \octal to work the DWIM way (that is, stop scanning
		 * as soon as non-octal characters are seen, complain only iff
		 * someone seems to want to use the digits eight and nine). */
		if (*s == '8' || *s == '9') {
		    if (ckWARN(WARN_DIGIT))
			Perl_warner(aTHX_ WARN_DIGIT,
				    "Illegal octal digit '%c' ignored", *s);
		}
		break;
	    }
	}
	if (!overflowed) {
	    register UV xuv = ruv << 3;

	    if ((xuv >> 3) != ruv) {
		overflowed = TRUE;
		rnv = (NV) ruv;
		if (ckWARN_d(WARN_OVERFLOW))
		    Perl_warner(aTHX_ WARN_OVERFLOW,
				"Integer overflow in octal number");
	    }
	    else
		ruv = xuv | (*s - '0');
	}
	if (overflowed) {
	    rnv *= 8.0;
	    /* If an NV has not enough bits in its mantissa to
	     * represent an UV this summing of small low-order numbers
	     * is a waste of time (because the NV cannot preserve
	     * the low-order bits anyway): we could just remember when
	     * did we overflow and in the end just multiply rnv by the
	     * right amount of 8-tuples. */
	    rnv += (NV)(*s - '0');
	}
    }
    if (!overflowed)
	rnv = (NV) ruv;
    if (   ( overflowed && rnv > 4294967295.0)
#if UVSIZE > 4
	|| (!overflowed && ruv > 0xffffffff  )
#endif
	) {
	if (ckWARN(WARN_PORTABLE))
	    Perl_warner(aTHX_ WARN_PORTABLE,
			"Octal number > 037777777777 non-portable");
    }
    *retlen = s - start;
    return rnv;
}

NV
Perl_scan_hex(pTHX_ char *start, STRLEN len, STRLEN *retlen)
{
    register char *s = start;
    register NV rnv = 0.0;
    register UV ruv = 0;
    register bool overflowed = FALSE;
    char *hexdigit;

    if (len > 2) {
	if (s[0] == 'x') {
	    s++;
	    len--;
	}
	else if (len > 3 && s[0] == '0' && s[1] == 'x') {
	    s+=2;
	    len-=2;
	}
    }

    for (; len-- && *s; s++) {
	hexdigit = strchr((char *) PL_hexdigit, *s);
	if (!hexdigit) {
	    if (*s == '_' && len && *retlen && s[1]
		&& (hexdigit = strchr((char *) PL_hexdigit, s[1])))
	    {
		--len;
		++s;
	    }
	    else {
		if (ckWARN(WARN_DIGIT))
		    Perl_warner(aTHX_ WARN_DIGIT,
				"Illegal hexadecimal digit '%c' ignored", *s);
		break;
	    }
	}
	if (!overflowed) {
	    register UV xuv = ruv << 4;

	    if ((xuv >> 4) != ruv) {
		overflowed = TRUE;
		rnv = (NV) ruv;
		if (ckWARN_d(WARN_OVERFLOW))
		    Perl_warner(aTHX_ WARN_OVERFLOW,
				"Integer overflow in hexadecimal number");
	    }
	    else
		ruv = xuv | ((hexdigit - PL_hexdigit) & 15);
	}
	if (overflowed) {
	    rnv *= 16.0;
	    /* If an NV has not enough bits in its mantissa to
	     * represent an UV this summing of small low-order numbers
	     * is a waste of time (because the NV cannot preserve
	     * the low-order bits anyway): we could just remember when
	     * did we overflow and in the end just multiply rnv by the
	     * right amount of 16-tuples. */
	    rnv += (NV)((hexdigit - PL_hexdigit) & 15);
	}
    }
    if (!overflowed)
	rnv = (NV) ruv;
    if (   ( overflowed && rnv > 4294967295.0)
#if UVSIZE > 4
	|| (!overflowed && ruv > 0xffffffff  )
#endif
	) {
	if (ckWARN(WARN_PORTABLE))
	    Perl_warner(aTHX_ WARN_PORTABLE,
			"Hexadecimal number > 0xffffffff non-portable");
    }
    *retlen = s - start;
    return rnv;
}

/*
=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
    if (PL_numeric_radix_sv && IN_LOCALE) { 
        STRLEN len;
        char* radix = SvPV(PL_numeric_radix_sv, len);
        if (*sp + len <= send && memEQ(*sp, radix, len)) {
            *sp += len;
            return TRUE; 
        }
    }
    /* always try "." if numeric radix didn't match because
     * we may have data from different locales mixed */
#endif
    if (*sp < send && **sp == '.') {
        ++*sp;
        return TRUE;
    }
    return FALSE;
}

/*
=for apidoc grok_number

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 (defined in perl.h).

If the value of the number can fit an in 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.

=cut
 */
int
Perl_grok_number(pTHX_ const char *pv, STRLEN len, UV *valuep)
{
  const char *s = pv;
  const char *send = pv + len;
  const UV max_div_10 = UV_MAX / 10;
  const char max_mod_10 = UV_MAX % 10;
  int numtype = 0;
  int sawinf = 0;

  while (s < send && isSPACE(*s))
    s++;
  if (s == send) {
    return 0;
  } else if (*s == '-') {
    s++;
    numtype = IS_NUMBER_NEG;
  }
  else if (*s == '+')
  s++;

  if (s == send)
    return 0;

  /* next must be digit or the radix separator or beginning of infinity */
  if (isDIGIT(*s)) {
    /* UVs are at least 32 bits, so the first 9 decimal digits cannot
       overflow.  */
    UV value = *s - '0';
    /* This construction seems to be more optimiser friendly.
       (without it gcc does the isDIGIT test and the *s - '0' separately)
       With it gcc on arm is managing 6 instructions (6 cycles) per digit.
       In theory the optimiser could deduce how far to unroll the loop
       before checking for overflow.  */
    if (++s < send) {
      int digit = *s - '0';
      if (digit >= 0 && digit <= 9) {
        value = value * 10 + digit;
        if (++s < send) {
          digit = *s - '0';
          if (digit >= 0 && digit <= 9) {
            value = value * 10 + digit;
            if (++s < send) {
              digit = *s - '0';
              if (digit >= 0 && digit <= 9) {
                value = value * 10 + digit;
		if (++s < send) {
                  digit = *s - '0';
                  if (digit >= 0 && digit <= 9) {
                    value = value * 10 + digit;
                    if (++s < send) {
                      digit = *s - '0';
                      if (digit >= 0 && digit <= 9) {
                        value = value * 10 + digit;
                        if (++s < send) {
                          digit = *s - '0';
                          if (digit >= 0 && digit <= 9) {
                            value = value * 10 + digit;
                            if (++s < send) {
                              digit = *s - '0';
                              if (digit >= 0 && digit <= 9) {
                                value = value * 10 + digit;
                                if (++s < send) {
                                  digit = *s - '0';
                                  if (digit >= 0 && digit <= 9) {
                                    value = value * 10 + digit;
                                    if (++s < send) {
                                      /* Now got 9 digits, so need to check
                                         each time for overflow.  */
                                      digit = *s - '0';
                                      while (digit >= 0 && digit <= 9
                                             && (value < max_div_10
                                                 || (value == max_div_10
                                                     && digit <= max_mod_10))) {
                                        value = value * 10 + digit;
                                        if (++s < send)
                                          digit = *s - '0';
                                        else
                                          break;
                                      }
                                      if (digit >= 0 && digit <= 9
                                          && (s < send)) {
                                        /* value overflowed.
                                           skip the remaining digits, don't
                                           worry about setting *valuep.  */
                                        do {
                                          s++;
                                        } while (s < send && isDIGIT(*s));
                                        numtype |=
                                          IS_NUMBER_GREATER_THAN_UV_MAX;
                                        goto skip_value;
                                      }
                                    }
                                  }
				}
                              }
                            }
                          }
                        }
                      }
                    }
                  }
                }
              }
            }
          }
	}
      }
    }
    numtype |= IS_NUMBER_IN_UV;
    if (valuep)
      *valuep = value;

  skip_value:
    if (GROK_NUMERIC_RADIX(&s, send)) {
      numtype |= IS_NUMBER_NOT_INT;
      while (s < send && isDIGIT(*s))  /* optional digits after the radix */
        s++;
    }
  }
  else if (GROK_NUMERIC_RADIX(&s, send)) {
    numtype |= IS_NUMBER_NOT_INT | IS_NUMBER_IN_UV; /* valuep assigned below */
    /* no digits before the radix means we need digits after it */
    if (s < send && isDIGIT(*s)) {
      do {
        s++;
      } while (s < send && isDIGIT(*s));
      if (valuep) {
        /* integer approximation is valid - it's 0.  */
        *valuep = 0;
      }
    }
    else
      return 0;
  } else if (*s == 'I' || *s == 'i') {
    s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
    s++; if (s == send || (*s != 'F' && *s != 'f')) return 0;
    s++; if (s < send && (*s == 'I' || *s == 'i')) {
      s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
      s++; if (s == send || (*s != 'I' && *s != 'i')) return 0;
      s++; if (s == send || (*s != 'T' && *s != 't')) return 0;
      s++; if (s == send || (*s != 'Y' && *s != 'y')) return 0;
      s++;
    }
    sawinf = 1;
  } else /* Add test for NaN here.  */
    return 0;

  if (sawinf) {
    numtype &= IS_NUMBER_NEG; /* Keep track of sign  */
    numtype |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT;
  } else if (s < send) {
    /* we can have an optional exponent part */
    if (*s == 'e' || *s == 'E') {
      /* The only flag we keep is sign.  Blow away any "it's UV"  */
      numtype &= IS_NUMBER_NEG;
      numtype |= IS_NUMBER_NOT_INT;
      s++;
      if (s < send && (*s == '-' || *s == '+'))
        s++;
      if (s < send && isDIGIT(*s)) {
        do {
          s++;
        } while (s < send && isDIGIT(*s));
      }
      else
      return 0;
    }
  }
  while (s < send && isSPACE(*s))
    s++;
  if (s >= send)
  return numtype;
  if (len == 10 && memEQ(pv, "0 but true", 10)) {
    if (valuep)
      *valuep = 0;
    return IS_NUMBER_IN_UV;
  }
  return 0;
}

NV
S_mulexp10(NV value, I32 exponent)
{
    NV result = 1.0;
    NV power = 10.0;
    bool negative = 0;
    I32 bit;

    if (exponent == 0)
	return value;
    else if (exponent < 0) {
	negative = 1;
	exponent = -exponent;
    }
#ifdef __VAX /* avoid %SYSTEM-F-FLTOVF_F sans VAXC$ESTABLISH */
#  if defined(__DECC_VER) && __DECC_VER <= 50390006
    /* __F_FLT_MAX_10_EXP - 5 == 33 */
    if (!negative &&
          (log10(value) + exponent) >= (__F_FLT_MAX_10_EXP - 5))
        return NV_MAX;
#  endif
#endif
    for (bit = 1; exponent; bit <<= 1) {
	if (exponent & bit) {
	    exponent ^= bit;
	    result *= power;
	}
	power *= power;
    }
    return negative ? value / result : value * result;
}

NV
Perl_my_atof(pTHX_ const char* s)
{
    NV x = 0.0;
#ifdef USE_LOCALE_NUMERIC
    if (PL_numeric_local && IN_LOCALE) {
	NV y;

	/* Scan the number twice; once using locale and once without;
	 * choose the larger result (in absolute value). */
	Perl_atof2(aTHX_ s, &x);
	SET_NUMERIC_STANDARD();
	Perl_atof2(aTHX_ s, &y);
	SET_NUMERIC_LOCAL();
	if ((y < 0.0 && y < x) || (y > 0.0 && y > x))
	    return y;
    }
    else
	Perl_atof2(aTHX_ s, &x);
#else
    Perl_atof2(aTHX_ s, &x);
#endif
    return x;
}

char*
Perl_my_atof2(pTHX_ const char* orig, NV* value)
{
    NV result = 0.0;
    bool negative = 0;
    char* s = (char*)orig;
    char* send = s + strlen(orig) - 1;
    bool seendigit = 0;
    I32 expextra = 0;
    I32 exponent = 0;
    I32 i;
/* this is arbitrary */
#define PARTLIM 6
/* we want the largest integers we can usefully use */
#if defined(HAS_QUAD) && defined(USE_64_BIT_INT)
#   define PARTSIZE ((int)TYPE_DIGITS(U64)-1)
    U64 part[PARTLIM];
#else
#   define PARTSIZE ((int)TYPE_DIGITS(U32)-1)
    U32 part[PARTLIM];
#endif
    I32 ipart = 0;	/* index into part[] */
    I32 offcount;	/* number of digits in least significant part */

    /* leading whitespace */
    while (isSPACE(*s))
	++s;

    /* sign */
    switch (*s) {
	case '-':
	    negative = 1;
	    /* fall through */
	case '+':
	    ++s;
    }

    part[0] = offcount = 0;
    if (isDIGIT(*s)) {
	seendigit = 1;	/* get this over with */

	/* skip leading zeros */
	while (*s == '0')
	    ++s;
    }

    /* integer digits */
    while (isDIGIT(*s)) {
	if (++offcount > PARTSIZE) {
	    if (++ipart < PARTLIM) {
		part[ipart] = 0;
		offcount = 1;	/* ++0 */
	    }
	    else {
		/* limits of precision reached */
		--ipart;
		--offcount;
		if (*s >= '5')
		    ++part[ipart];
		while (isDIGIT(*s)) {
		    ++expextra;
		    ++s;
		}
		/* warn of loss of precision? */
		break;
	    }
	}
	part[ipart] = part[ipart] * 10 + (*s++ - '0');
    }

    /* decimal point */
    if (GROK_NUMERIC_RADIX((const char **)&s, send)) {
	if (isDIGIT(*s))
	    seendigit = 1;	/* get this over with */

	/* decimal digits */
	while (isDIGIT(*s)) {
	    if (++offcount > PARTSIZE) {
		if (++ipart < PARTLIM) {
		    part[ipart] = 0;
		    offcount = 1;	/* ++0 */
		}
		else {
		    /* limits of precision reached */
		    --ipart;
		    --offcount;
		    if (*s >= '5')
			++part[ipart];
		    while (isDIGIT(*s))
			++s;
		    /* warn of loss of precision? */
		    break;
		}
	    }
	    --expextra;
	    part[ipart] = part[ipart] * 10 + (*s++ - '0');
	}
    }

    /* combine components of mantissa */
    for (i = 0; i <= ipart; ++i)
	result += S_mulexp10((NV)part[ipart - i],
		i ? offcount + (i - 1) * PARTSIZE : 0);

    if (seendigit && (*s == 'e' || *s == 'E')) {
	bool expnegative = 0;

	++s;
	switch (*s) {
	    case '-':
		expnegative = 1;
		/* fall through */
	    case '+':
		++s;
	}
	while (isDIGIT(*s))
	    exponent = exponent * 10 + (*s++ - '0');
	if (expnegative)
	    exponent = -exponent;
    }

    /* now apply the exponent */
    exponent += expextra;
    result = S_mulexp10(result, exponent);

    /* now apply the sign */
    if (negative)
	result = -result;
    *value = result;
    return s;
}
Commit	Line	Data
98994639 HS	1	/* numeric.c
	2	*
	3	* Copyright (c) 2001, Larry Wall
	4	*
	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.
	7	*
	8	*/
	9
	10	/*
	11	* "That only makes eleven (plus one mislaid) and not fourteen, unless
	12	* wizards count differently to other people."
	13	*/
	14
	15	#include "EXTERN.h"
	16	#define PERL_IN_NUMERIC_C
	17	#include "perl.h"
	18
	19	U32
	20	Perl_cast_ulong(pTHX_ NV f)
	21	{
	22	if (f < 0.0)
	23	return f < I32_MIN ? (U32) I32_MIN : (U32)(I32) f;
	24	if (f < U32_MAX_P1) {
	25	#if CASTFLAGS & 2
	26	if (f < U32_MAX_P1_HALF)
	27	return (U32) f;
	28	f -= U32_MAX_P1_HALF;
	29	return ((U32) f) \| (1 + U32_MAX >> 1);
	30	#else
	31	return (U32) f;
	32	#endif
	33	}
	34	return f > 0 ? U32_MAX : 0 /* NaN */;
	35	}
	36
	37	I32
	38	Perl_cast_i32(pTHX_ NV f)
	39	{
	40	if (f < I32_MAX_P1)
	41	return f < I32_MIN ? I32_MIN : (I32) f;
	42	if (f < U32_MAX_P1) {
	43	#if CASTFLAGS & 2
	44	if (f < U32_MAX_P1_HALF)
	45	return (I32)(U32) f;
	46	f -= U32_MAX_P1_HALF;
	47	return (I32)(((U32) f) \| (1 + U32_MAX >> 1));
	48	#else
	49	return (I32)(U32) f;
	50	#endif
	51	}
	52	return f > 0 ? (I32)U32_MAX : 0 /* NaN */;
	53	}
	54
	55	IV
	56	Perl_cast_iv(pTHX_ NV f)
	57	{
	58	if (f < IV_MAX_P1)
	59	return f < IV_MIN ? IV_MIN : (IV) f;
	60	if (f < UV_MAX_P1) {
	61	#if CASTFLAGS & 2
	62	/* For future flexibility allowing for sizeof(UV) >= sizeof(IV) */
	63	if (f < UV_MAX_P1_HALF)
	64	return (IV)(UV) f;
65	f -= UV_MAX_P1_HALF;
66	return (IV)(((UV) f) \| (1 + UV_MAX >> 1));
67	#else
68	return (IV)(UV) f;
69	#endif
70	}
71	return f > 0 ? (IV)UV_MAX : 0 /* NaN */;
72	}
73
74	UV
75	Perl_cast_uv(pTHX_ NV f)
76	{
77	if (f < 0.0)
78	return f < IV_MIN ? (UV) IV_MIN : (UV)(IV) f;
79	if (f < UV_MAX_P1) {
80	#if CASTFLAGS & 2
81	if (f < UV_MAX_P1_HALF)
82	return (UV) f;
83	f -= UV_MAX_P1_HALF;
84	return ((UV) f) \| (1 + UV_MAX >> 1);
85	#else
86	return (UV) f;
87	#endif
88	}
89	return f > 0 ? UV_MAX : 0 /* NaN */;
90	}
91
92	#if defined(HUGE_VAL) \|\| (defined(USE_LONG_DOUBLE) && defined(HUGE_VALL))
93	/*
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.
97	*/
98	NV
99	Perl_huge(void)
100	{
101	# if defined(USE_LONG_DOUBLE) && defined(HUGE_VALL)
102	return HUGE_VALL;
103	# endif
104	return HUGE_VAL;
105	}
106	#endif
107
108	NV
109	Perl_scan_bin(pTHX_ char start, STRLEN len, STRLEN retlen)
110	{
111	register char *s = start;
112	register NV rnv = 0.0;
113	register UV ruv = 0;
114	register bool seenb = FALSE;
115	register bool overflowed = FALSE;
116
117	for (; len-- && *s; s++) {
118	if (!(s == '0' \|\| s == '1')) {
119	if (s == '_' && len && retlen
120	&& (s[1] == '0' \|\| s[1] == '1'))
121	{
122	--len;
123	++s;
124	}
125	else if (seenb == FALSE && *s == 'b' && ruv == 0) {
126	/* Disallow 0bbb0b0bbb... */
127	seenb = TRUE;
128	continue;
129	}
130	else {
131	if (ckWARN(WARN_DIGIT))
132	Perl_warner(aTHX_ WARN_DIGIT,
133	"Illegal binary digit '%c' ignored", *s);
134	break;
135	}
136	}
137	if (!overflowed) {
138	register UV xuv = ruv << 1;
139
140	if ((xuv >> 1) != ruv) {
141	overflowed = TRUE;
142	rnv = (NV) ruv;
143	if (ckWARN_d(WARN_OVERFLOW))
144	Perl_warner(aTHX_ WARN_OVERFLOW,
145	"Integer overflow in binary number");
146	}
147	else
148	ruv = xuv \| (*s - '0');
149	}
150	if (overflowed) {
151	rnv *= 2;
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
157	* right amount. */
158	rnv += (*s - '0');
159	}
160	}
161	if (!overflowed)
162	rnv = (NV) ruv;
163	if ( ( overflowed && rnv > 4294967295.0)
164	#if UVSIZE > 4
165	\|\| (!overflowed && ruv > 0xffffffff )
166	#endif
167	) {
168	if (ckWARN(WARN_PORTABLE))
169	Perl_warner(aTHX_ WARN_PORTABLE,
170	"Binary number > 0b11111111111111111111111111111111 non-portable");
171	}
172	*retlen = s - start;
173	return rnv;
174	}
175
176	NV
177	Perl_scan_oct(pTHX_ char start, STRLEN len, STRLEN retlen)
178	{
179	register char *s = start;
180	register NV rnv = 0.0;
181	register UV ruv = 0;
182	register bool overflowed = FALSE;
183
184	for (; len-- && *s; s++) {
185	if (!(s >= '0' && s <= '7')) {
186	if (s == '_' && len && retlen
187	&& (s[1] >= '0' && s[1] <= '7'))
188	{
189	--len;
190	++s;
191	}
192	else {
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);
200	}
201	break;
202	}
203	}
204	if (!overflowed) {
205	register UV xuv = ruv << 3;
206
207	if ((xuv >> 3) != ruv) {
208	overflowed = TRUE;
209	rnv = (NV) ruv;
210	if (ckWARN_d(WARN_OVERFLOW))
211	Perl_warner(aTHX_ WARN_OVERFLOW,
212	"Integer overflow in octal number");
213	}
214	else
215	ruv = xuv \| (*s - '0');
216	}
217	if (overflowed) {
218	rnv *= 8.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');
226	}
227	}
228	if (!overflowed)
229	rnv = (NV) ruv;
230	if ( ( overflowed && rnv > 4294967295.0)
231	#if UVSIZE > 4
232	\|\| (!overflowed && ruv > 0xffffffff )
233	#endif
234	) {
235	if (ckWARN(WARN_PORTABLE))
236	Perl_warner(aTHX_ WARN_PORTABLE,
237	"Octal number > 037777777777 non-portable");
238	}
239	*retlen = s - start;
240	return rnv;
241	}
242
243	NV
244	Perl_scan_hex(pTHX_ char start, STRLEN len, STRLEN retlen)
245	{
246	register char *s = start;
247	register NV rnv = 0.0;
248	register UV ruv = 0;
249	register bool overflowed = FALSE;
250	char *hexdigit;
251
252	if (len > 2) {
253	if (s[0] == 'x') {
254	s++;
255	len--;
256	}
257	else if (len > 3 && s[0] == '0' && s[1] == 'x') {
258	s+=2;
259	len-=2;
260	}
261	}
262
263	for (; len-- && *s; s++) {
264	hexdigit = strchr((char ) PL_hexdigit, s);
265	if (!hexdigit) {
266	if (s == '_' && len && retlen && s[1]
267	&& (hexdigit = strchr((char *) PL_hexdigit, s[1])))
268	{
269	--len;
270	++s;
271	}
272	else {
273	if (ckWARN(WARN_DIGIT))
274	Perl_warner(aTHX_ WARN_DIGIT,
275	"Illegal hexadecimal digit '%c' ignored", *s);
276	break;
277	}
278	}
279	if (!overflowed) {
280	register UV xuv = ruv << 4;
281
282	if ((xuv >> 4) != ruv) {
283	overflowed = TRUE;
284	rnv = (NV) ruv;
285	if (ckWARN_d(WARN_OVERFLOW))
286	Perl_warner(aTHX_ WARN_OVERFLOW,
287	"Integer overflow in hexadecimal number");
288	}
289	else
290	ruv = xuv \| ((hexdigit - PL_hexdigit) & 15);
291	}
292	if (overflowed) {
293	rnv *= 16.0;
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);
301	}
302	}
303	if (!overflowed)
304	rnv = (NV) ruv;
305	if ( ( overflowed && rnv > 4294967295.0)
306	#if UVSIZE > 4
307	\|\| (!overflowed && ruv > 0xffffffff )
308	#endif
309	) {
310	if (ckWARN(WARN_PORTABLE))
311	Perl_warner(aTHX_ WARN_PORTABLE,
312	"Hexadecimal number > 0xffffffff non-portable");
313	}
314	*retlen = s - start;
315	return rnv;
316	}
317
318	/*
319	=for apidoc grok_numeric_radix
320
321	Scan and skip for a numeric decimal separator (radix).
322
323	=cut
324	*/
325	bool
326	Perl_grok_numeric_radix(pTHX_ const char *sp, const char send)
327	{
328	#ifdef USE_LOCALE_NUMERIC
329	if (PL_numeric_radix_sv && IN_LOCALE) {
330	STRLEN len;
331	char* radix = SvPV(PL_numeric_radix_sv, len);
332	if (sp + len <= send && memEQ(sp, radix, len)) {
333	*sp += len;
334	return TRUE;
335	}
336	}
337	/* always try "." if numeric radix didn't match because
338	* we may have data from different locales mixed */
339	#endif
340	if (sp < send && *sp == '.') {
341	++*sp;
342	return TRUE;
343	}
344	return FALSE;
345	}
346
347	/*
348	=for apidoc grok_number
349
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,
60939fb8 NC	353	IS_NUMBER_NEG, IS_NUMBER_INFINITY (defined in perl.h).
	354
	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.
	361
	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.
98994639 HS	367
	368	=cut
	369	*/
	370	int
	371	Perl_grok_number(pTHX_ const char pv, STRLEN len, UV valuep)
	372	{
60939fb8 NC	373	const char *s = pv;
	374	const char *send = pv + len;
	375	const UV max_div_10 = UV_MAX / 10;
	376	const char max_mod_10 = UV_MAX % 10;
	377	int numtype = 0;
	378	int sawinf = 0;
	379
	380	while (s < send && isSPACE(*s))
	381	s++;
	382	if (s == send) {
	383	return 0;
	384	} else if (*s == '-') {
	385	s++;
	386	numtype = IS_NUMBER_NEG;
	387	}
	388	else if (*s == '+')
	389	s++;
	390
	391	if (s == send)
	392	return 0;
	393
	394	/* next must be digit or the radix separator or beginning of infinity */
	395	if (isDIGIT(*s)) {
	396	/* UVs are at least 32 bits, so the first 9 decimal digits cannot
	397	overflow. */
	398	UV value = *s - '0';
	399	/* This construction seems to be more optimiser friendly.
	400	(without it gcc does the isDIGIT test and the *s - '0' separately)
	401	With it gcc on arm is managing 6 instructions (6 cycles) per digit.
	402	In theory the optimiser could deduce how far to unroll the loop
	403	before checking for overflow. */
58bb9ec3 NC	404	if (++s < send) {
58bb9ec3 NC	405	int digit = *s - '0';
60939fb8 NC	406	if (digit >= 0 && digit <= 9) {
60939fb8 NC	407	value = value * 10 + digit;
58bb9ec3 NC	408	if (++s < send) {
58bb9ec3 NC	409	digit = *s - '0';
60939fb8 NC	410	if (digit >= 0 && digit <= 9) {
60939fb8 NC	411	value = value * 10 + digit;
58bb9ec3 NC	412	if (++s < send) {
58bb9ec3 NC	413	digit = *s - '0';
60939fb8 NC	414	if (digit >= 0 && digit <= 9) {
60939fb8 NC	415	value = value * 10 + digit;
58bb9ec3 NC	416	if (++s < send) {
58bb9ec3 NC	417	digit = *s - '0';
60939fb8 NC	418	if (digit >= 0 && digit <= 9) {
60939fb8 NC	419	value = value * 10 + digit;
58bb9ec3 NC	420	if (++s < send) {
58bb9ec3 NC	421	digit = *s - '0';
60939fb8 NC	422	if (digit >= 0 && digit <= 9) {
60939fb8 NC	423	value = value * 10 + digit;
58bb9ec3 NC	424	if (++s < send) {
58bb9ec3 NC	425	digit = *s - '0';
60939fb8 NC	426	if (digit >= 0 && digit <= 9) {
60939fb8 NC	427	value = value * 10 + digit;
58bb9ec3 NC	428	if (++s < send) {
58bb9ec3 NC	429	digit = *s - '0';
60939fb8 NC	430	if (digit >= 0 && digit <= 9) {
60939fb8 NC	431	value = value * 10 + digit;
58bb9ec3 NC	432	if (++s < send) {
58bb9ec3 NC	433	digit = *s - '0';
60939fb8 NC	434	if (digit >= 0 && digit <= 9) {
60939fb8 NC	435	value = value * 10 + digit;
58bb9ec3	436	if (++s < send) {
60939fb8 NC	437	/* Now got 9 digits, so need to check
60939fb8 NC	438	each time for overflow. */
58bb9ec3	439	digit = *s - '0';
60939fb8 NC	440	while (digit >= 0 && digit <= 9
	441	&& (value < max_div_10
	442	\|\| (value == max_div_10
	443	&& digit <= max_mod_10))) {
	444	value = value * 10 + digit;
58bb9ec3 NC	445	if (++s < send)
58bb9ec3 NC	446	digit = *s - '0';
60939fb8 NC	447	else
	448	break;
	449	}
	450	if (digit >= 0 && digit <= 9
51bd16da	451	&& (s < send)) {
60939fb8 NC	452	/* value overflowed.
	453	skip the remaining digits, don't
	454	worry about setting valuep. /
	455	do {
	456	s++;
	457	} while (s < send && isDIGIT(*s));
	458	numtype \|=
	459	IS_NUMBER_GREATER_THAN_UV_MAX;
	460	goto skip_value;
	461	}
	462	}
	463	}
98994639	464	}
60939fb8 NC	465	}
	466	}
	467	}
	468	}
	469	}
	470	}
	471	}
	472	}
	473	}
	474	}
	475	}
98994639	476	}
60939fb8	477	}
98994639	478	}
60939fb8 NC	479	numtype \|= IS_NUMBER_IN_UV;
	480	if (valuep)
	481	*valuep = value;
	482
	483	skip_value:
	484	if (GROK_NUMERIC_RADIX(&s, send)) {
	485	numtype \|= IS_NUMBER_NOT_INT;
	486	while (s < send && isDIGIT(s)) / optional digits after the radix */
	487	s++;
98994639	488	}
60939fb8 NC	489	}
	490	else if (GROK_NUMERIC_RADIX(&s, send)) {
	491	numtype \|= IS_NUMBER_NOT_INT \| IS_NUMBER_IN_UV; /* valuep assigned below */
	492	/* no digits before the radix means we need digits after it */
	493	if (s < send && isDIGIT(*s)) {
	494	do {
	495	s++;
	496	} while (s < send && isDIGIT(*s));
	497	if (valuep) {
	498	/* integer approximation is valid - it's 0. */
	499	*valuep = 0;
	500	}
98994639	501	}
60939fb8 NC	502	else
	503	return 0;
	504	} else if (s == 'I' \|\| s == 'i') {
	505	s++; if (s == send \|\| (s != 'N' && s != 'n')) return 0;
	506	s++; if (s == send \|\| (s != 'F' && s != 'f')) return 0;
	507	s++; if (s < send && (s == 'I' \|\| s == 'i')) {
	508	s++; if (s == send \|\| (s != 'N' && s != 'n')) return 0;
	509	s++; if (s == send \|\| (s != 'I' && s != 'i')) return 0;
	510	s++; if (s == send \|\| (s != 'T' && s != 't')) return 0;
	511	s++; if (s == send \|\| (s != 'Y' && s != 'y')) return 0;
	512	s++;
98994639	513	}
60939fb8 NC	514	sawinf = 1;
60939fb8 NC	515	} else /* Add test for NaN here. */
98994639	516	return 0;
60939fb8 NC	517
	518	if (sawinf) {
	519	numtype &= IS_NUMBER_NEG; /* Keep track of sign */
	520	numtype \|= IS_NUMBER_INFINITY \| IS_NUMBER_NOT_INT;
	521	} else if (s < send) {
	522	/* we can have an optional exponent part */
	523	if (s == 'e' \|\| s == 'E') {
	524	/* The only flag we keep is sign. Blow away any "it's UV" */
	525	numtype &= IS_NUMBER_NEG;
	526	numtype \|= IS_NUMBER_NOT_INT;
	527	s++;
	528	if (s < send && (s == '-' \|\| s == '+'))
	529	s++;
	530	if (s < send && isDIGIT(*s)) {
	531	do {
	532	s++;
	533	} while (s < send && isDIGIT(*s));
	534	}
	535	else
	536	return 0;
	537	}
	538	}
	539	while (s < send && isSPACE(*s))
	540	s++;
	541	if (s >= send)
	542	return numtype;
	543	if (len == 10 && memEQ(pv, "0 but true", 10)) {
	544	if (valuep)
	545	*valuep = 0;
	546	return IS_NUMBER_IN_UV;
	547	}
	548	return 0;
98994639 HS	549	}
	550
	551	NV
	552	S_mulexp10(NV value, I32 exponent)
	553	{
	554	NV result = 1.0;
	555	NV power = 10.0;
	556	bool negative = 0;
	557	I32 bit;
	558
	559	if (exponent == 0)
	560	return value;
	561	else if (exponent < 0) {
	562	negative = 1;
	563	exponent = -exponent;
	564	}
a333faaf PP	565	#ifdef __VAX /* avoid %SYSTEM-F-FLTOVF_F sans VAXC$ESTABLISH */
	566	# if defined(__DECC_VER) && __DECC_VER <= 50390006
	567	/* __F_FLT_MAX_10_EXP - 5 == 33 */
	568	if (!negative &&
	569	(log10(value) + exponent) >= (__F_FLT_MAX_10_EXP - 5))
	570	return NV_MAX;
	571	# endif
	572	#endif
98994639 HS	573	for (bit = 1; exponent; bit <<= 1) {
	574	if (exponent & bit) {
	575	exponent ^= bit;
	576	result *= power;
	577	}
	578	power *= power;
	579	}
	580	return negative ? value / result : value * result;
	581	}
	582
	583	NV
	584	Perl_my_atof(pTHX_ const char* s)
	585	{
	586	NV x = 0.0;
	587	#ifdef USE_LOCALE_NUMERIC
	588	if (PL_numeric_local && IN_LOCALE) {
	589	NV y;
	590
	591	/* Scan the number twice; once using locale and once without;
	592	* choose the larger result (in absolute value). */
	593	Perl_atof2(aTHX_ s, &x);
	594	SET_NUMERIC_STANDARD();
	595	Perl_atof2(aTHX_ s, &y);
	596	SET_NUMERIC_LOCAL();
	597	if ((y < 0.0 && y < x) \|\| (y > 0.0 && y > x))
	598	return y;
	599	}
	600	else
	601	Perl_atof2(aTHX_ s, &x);
	602	#else
	603	Perl_atof2(aTHX_ s, &x);
	604	#endif
	605	return x;
	606	}
	607
	608	char*
	609	Perl_my_atof2(pTHX_ const char* orig, NV* value)
	610	{
	611	NV result = 0.0;
	612	bool negative = 0;
	613	char* s = (char*)orig;
	614	char* send = s + strlen(orig) - 1;
	615	bool seendigit = 0;
	616	I32 expextra = 0;
	617	I32 exponent = 0;
	618	I32 i;
	619	/* this is arbitrary */
	620	#define PARTLIM 6
	621	/* we want the largest integers we can usefully use */
	622	#if defined(HAS_QUAD) && defined(USE_64_BIT_INT)
	623	# define PARTSIZE ((int)TYPE_DIGITS(U64)-1)
	624	U64 part[PARTLIM];
	625	#else
	626	# define PARTSIZE ((int)TYPE_DIGITS(U32)-1)
	627	U32 part[PARTLIM];
	628	#endif
	629	I32 ipart = 0; /* index into part[] */
	630	I32 offcount; /* number of digits in least significant part */
	631
96a05aee HS	632	/* leading whitespace */
	633	while (isSPACE(*s))
	634	++s;
	635
98994639 HS	636	/* sign */
	637	switch (*s) {
	638	case '-':
	639	negative = 1;
	640	/* fall through */
	641	case '+':
	642	++s;
	643	}
	644
	645	part[0] = offcount = 0;
	646	if (isDIGIT(*s)) {
	647	seendigit = 1; /* get this over with */
	648
	649	/* skip leading zeros */
	650	while (*s == '0')
	651	++s;
	652	}
	653
	654	/* integer digits */
	655	while (isDIGIT(*s)) {
	656	if (++offcount > PARTSIZE) {
	657	if (++ipart < PARTLIM) {
	658	part[ipart] = 0;
	659	offcount = 1; /* ++0 */
	660	}
	661	else {
	662	/* limits of precision reached */
	663	--ipart;
	664	--offcount;
	665	if (*s >= '5')
	666	++part[ipart];
	667	while (isDIGIT(*s)) {
	668	++expextra;
	669	++s;
	670	}
	671	/* warn of loss of precision? */
	672	break;
	673	}
	674	}
	675	part[ipart] = part[ipart] * 10 + (*s++ - '0');
	676	}
	677
	678	/* decimal point */
	679	if (GROK_NUMERIC_RADIX((const char **)&s, send)) {
	680	if (isDIGIT(*s))
	681	seendigit = 1; /* get this over with */
	682
	683	/* decimal digits */
	684	while (isDIGIT(*s)) {
	685	if (++offcount > PARTSIZE) {
	686	if (++ipart < PARTLIM) {
	687	part[ipart] = 0;
	688	offcount = 1; /* ++0 */
	689	}
	690	else {
	691	/* limits of precision reached */
	692	--ipart;
	693	--offcount;
	694	if (*s >= '5')
	695	++part[ipart];
	696	while (isDIGIT(*s))
	697	++s;
	698	/* warn of loss of precision? */
	699	break;
700	}
701	}
702	--expextra;
703	part[ipart] = part[ipart] * 10 + (*s++ - '0');
704	}
705	}
706
707	/* combine components of mantissa */
708	for (i = 0; i <= ipart; ++i)
709	result += S_mulexp10((NV)part[ipart - i],
710	i ? offcount + (i - 1) * PARTSIZE : 0);
711
712	if (seendigit && (s == 'e' \|\| s == 'E')) {
713	bool expnegative = 0;
714
715	++s;
716	switch (*s) {
717	case '-':
718	expnegative = 1;
719	/* fall through */
720	case '+':
721	++s;
722	}
723	while (isDIGIT(*s))
724	exponent = exponent * 10 + (*s++ - '0');
725	if (expnegative)
726	exponent = -exponent;
727	}
728
729	/* now apply the exponent */
730	exponent += expextra;
731	result = S_mulexp10(result, exponent);
732
733	/* now apply the sign */
734	if (negative)
735	result = -result;
736	*value = result;
737	return s;
738	}
739