perl/numeric.c
<<
>>
Prefs
   1/*    numeric.c
   2 *
   3 *    Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,
   4 *    2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
   5 *
   6 *    You may distribute under the terms of either the GNU General Public
   7 *    License or the Artistic License, as specified in the README file.
   8 *
   9 */
  10
  11/*
  12 * "That only makes eleven (plus one mislaid) and not fourteen,
  13 *  unless wizards count differently to other people."  --Beorn
  14 *
  15 *     [p.115 of _The Hobbit_: "Queer Lodgings"]
  16 */
  17
  18/*
  19=head1 Numeric functions
  20
  21This file contains all the stuff needed by perl for manipulating numeric
  22values, including such things as replacements for the OS's atof() function
  23
  24=cut
  25
  26*/
  27
  28#include "EXTERN.h"
  29#define PERL_IN_NUMERIC_C
  30#include "perl.h"
  31
  32U32
  33Perl_cast_ulong(pTHX_ NV f)
  34{
  35    PERL_UNUSED_CONTEXT;
  36  if (f < 0.0)
  37    return f < I32_MIN ? (U32) I32_MIN : (U32)(I32) f;
  38  if (f < U32_MAX_P1) {
  39#if CASTFLAGS & 2
  40    if (f < U32_MAX_P1_HALF)
  41      return (U32) f;
  42    f -= U32_MAX_P1_HALF;
  43    return ((U32) f) | (1 + U32_MAX >> 1);
  44#else
  45    return (U32) f;
  46#endif
  47  }
  48  return f > 0 ? U32_MAX : 0 /* NaN */;
  49}
  50
  51I32
  52Perl_cast_i32(pTHX_ NV f)
  53{
  54    PERL_UNUSED_CONTEXT;
  55  if (f < I32_MAX_P1)
  56    return f < I32_MIN ? I32_MIN : (I32) f;
  57  if (f < U32_MAX_P1) {
  58#if CASTFLAGS & 2
  59    if (f < U32_MAX_P1_HALF)
  60      return (I32)(U32) f;
  61    f -= U32_MAX_P1_HALF;
  62    return (I32)(((U32) f) | (1 + U32_MAX >> 1));
  63#else
  64    return (I32)(U32) f;
  65#endif
  66  }
  67  return f > 0 ? (I32)U32_MAX : 0 /* NaN */;
  68}
  69
  70IV
  71Perl_cast_iv(pTHX_ NV f)
  72{
  73    PERL_UNUSED_CONTEXT;
  74  if (f < IV_MAX_P1)
  75    return f < IV_MIN ? IV_MIN : (IV) f;
  76  if (f < UV_MAX_P1) {
  77#if CASTFLAGS & 2
  78    /* For future flexibility allowing for sizeof(UV) >= sizeof(IV)  */
  79    if (f < UV_MAX_P1_HALF)
  80      return (IV)(UV) f;
  81    f -= UV_MAX_P1_HALF;
  82    return (IV)(((UV) f) | (1 + UV_MAX >> 1));
  83#else
  84    return (IV)(UV) f;
  85#endif
  86  }
  87  return f > 0 ? (IV)UV_MAX : 0 /* NaN */;
  88}
  89
  90UV
  91Perl_cast_uv(pTHX_ NV f)
  92{
  93    PERL_UNUSED_CONTEXT;
  94  if (f < 0.0)
  95    return f < IV_MIN ? (UV) IV_MIN : (UV)(IV) f;
  96  if (f < UV_MAX_P1) {
  97#if CASTFLAGS & 2
  98    if (f < UV_MAX_P1_HALF)
  99      return (UV) f;
 100    f -= UV_MAX_P1_HALF;
 101    return ((UV) f) | (1 + UV_MAX >> 1);
 102#else
 103    return (UV) f;
 104#endif
 105  }
 106  return f > 0 ? UV_MAX : 0 /* NaN */;
 107}
 108
 109/*
 110=for apidoc grok_bin
 111
 112converts a string representing a binary number to numeric form.
 113
 114On entry I<start> and I<*len> give the string to scan, I<*flags> gives
 115conversion flags, and I<result> should be NULL or a pointer to an NV.
 116The scan stops at the end of the string, or the first invalid character.
 117Unless C<PERL_SCAN_SILENT_ILLDIGIT> is set in I<*flags>, encountering an
 118invalid character will also trigger a warning.
 119On return I<*len> is set to the length of the scanned string,
 120and I<*flags> gives output flags.
 121
 122If the value is <= C<UV_MAX> it is returned as a UV, the output flags are clear,
 123and nothing is written to I<*result>. If the value is > UV_MAX C<grok_bin>
 124returns UV_MAX, sets C<PERL_SCAN_GREATER_THAN_UV_MAX> in the output flags,
 125and writes the value to I<*result> (or the value is discarded if I<result>
 126is NULL).
 127
 128The binary number may optionally be prefixed with "0b" or "b" unless
 129C<PERL_SCAN_DISALLOW_PREFIX> is set in I<*flags> on entry. If
 130C<PERL_SCAN_ALLOW_UNDERSCORES> is set in I<*flags> then the binary
 131number may use '_' characters to separate digits.
 132
 133=cut
 134 */
 135
 136UV
 137Perl_grok_bin(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result)
 138{
 139    const char *s = start;
 140    STRLEN len = *len_p;
 141    UV value = 0;
 142    NV value_nv = 0;
 143
 144    const UV max_div_2 = UV_MAX / 2;
 145    const bool allow_underscores = (bool)(*flags & PERL_SCAN_ALLOW_UNDERSCORES);
 146    bool overflowed = FALSE;
 147    char bit;
 148
 149    PERL_ARGS_ASSERT_GROK_BIN;
 150
 151    if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) {
 152        /* strip off leading b or 0b.
 153           for compatibility silently suffer "b" and "0b" as valid binary
 154           numbers. */
 155        if (len >= 1) {
 156            if (s[0] == 'b') {
 157                s++;
 158                len--;
 159            }
 160            else if (len >= 2 && s[0] == '0' && s[1] == 'b') {
 161                s+=2;
 162                len-=2;
 163            }
 164        }
 165    }
 166
 167    for (; len-- && (bit = *s); s++) {
 168        if (bit == '0' || bit == '1') {
 169            /* Write it in this wonky order with a goto to attempt to get the
 170               compiler to make the common case integer-only loop pretty tight.
 171               With gcc seems to be much straighter code than old scan_bin.  */
 172          redo:
 173            if (!overflowed) {
 174                if (value <= max_div_2) {
 175                    value = (value << 1) | (bit - '0');
 176                    continue;
 177                }
 178                /* Bah. We're just overflowed.  */
 179                if (ckWARN_d(WARN_OVERFLOW))
 180                    Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
 181                                "Integer overflow in binary number");
 182                overflowed = TRUE;
 183                value_nv = (NV) value;
 184            }
 185            value_nv *= 2.0;
 186            /* If an NV has not enough bits in its mantissa to
 187             * represent a UV this summing of small low-order numbers
 188             * is a waste of time (because the NV cannot preserve
 189             * the low-order bits anyway): we could just remember when
 190             * did we overflow and in the end just multiply value_nv by the
 191             * right amount. */
 192            value_nv += (NV)(bit - '0');
 193            continue;
 194        }
 195        if (bit == '_' && len && allow_underscores && (bit = s[1])
 196            && (bit == '0' || bit == '1'))
 197            {
 198                --len;
 199                ++s;
 200                goto redo;
 201            }
 202        if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT) && ckWARN(WARN_DIGIT))
 203            Perl_warner(aTHX_ packWARN(WARN_DIGIT),
 204                        "Illegal binary digit '%c' ignored", *s);
 205        break;
 206    }
 207    
 208    if (   ( overflowed && value_nv > 4294967295.0)
 209#if UVSIZE > 4
 210        || (!overflowed && value > 0xffffffff  )
 211#endif
 212        ) {
 213        if (ckWARN(WARN_PORTABLE))
 214            Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
 215                        "Binary number > 0b11111111111111111111111111111111 non-portable");
 216    }
 217    *len_p = s - start;
 218    if (!overflowed) {
 219        *flags = 0;
 220        return value;
 221    }
 222    *flags = PERL_SCAN_GREATER_THAN_UV_MAX;
 223    if (result)
 224        *result = value_nv;
 225    return UV_MAX;
 226}
 227
 228/*
 229=for apidoc grok_hex
 230
 231converts a string representing a hex number to numeric form.
 232
 233On entry I<start> and I<*len> give the string to scan, I<*flags> gives
 234conversion flags, and I<result> should be NULL or a pointer to an NV.
 235The scan stops at the end of the string, or the first invalid character.
 236Unless C<PERL_SCAN_SILENT_ILLDIGIT> is set in I<*flags>, encountering an
 237invalid character will also trigger a warning.
 238On return I<*len> is set to the length of the scanned string,
 239and I<*flags> gives output flags.
 240
 241If the value is <= UV_MAX it is returned as a UV, the output flags are clear,
 242and nothing is written to I<*result>. If the value is > UV_MAX C<grok_hex>
 243returns UV_MAX, sets C<PERL_SCAN_GREATER_THAN_UV_MAX> in the output flags,
 244and writes the value to I<*result> (or the value is discarded if I<result>
 245is NULL).
 246
 247The hex number may optionally be prefixed with "0x" or "x" unless
 248C<PERL_SCAN_DISALLOW_PREFIX> is set in I<*flags> on entry. If
 249C<PERL_SCAN_ALLOW_UNDERSCORES> is set in I<*flags> then the hex
 250number may use '_' characters to separate digits.
 251
 252=cut
 253 */
 254
 255UV
 256Perl_grok_hex(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result)
 257{
 258    dVAR;
 259    const char *s = start;
 260    STRLEN len = *len_p;
 261    UV value = 0;
 262    NV value_nv = 0;
 263    const UV max_div_16 = UV_MAX / 16;
 264    const bool allow_underscores = (bool)(*flags & PERL_SCAN_ALLOW_UNDERSCORES);
 265    bool overflowed = FALSE;
 266
 267    PERL_ARGS_ASSERT_GROK_HEX;
 268
 269    if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) {
 270        /* strip off leading x or 0x.
 271           for compatibility silently suffer "x" and "0x" as valid hex numbers.
 272        */
 273        if (len >= 1) {
 274            if (s[0] == 'x') {
 275                s++;
 276                len--;
 277            }
 278            else if (len >= 2 && s[0] == '0' && s[1] == 'x') {
 279                s+=2;
 280                len-=2;
 281            }
 282        }
 283    }
 284
 285    for (; len-- && *s; s++) {
 286        const char *hexdigit = strchr(PL_hexdigit, *s);
 287        if (hexdigit) {
 288            /* Write it in this wonky order with a goto to attempt to get the
 289               compiler to make the common case integer-only loop pretty tight.
 290               With gcc seems to be much straighter code than old scan_hex.  */
 291          redo:
 292            if (!overflowed) {
 293                if (value <= max_div_16) {
 294                    value = (value << 4) | ((hexdigit - PL_hexdigit) & 15);
 295                    continue;
 296                }
 297                /* Bah. We're just overflowed.  */
 298                if (ckWARN_d(WARN_OVERFLOW))
 299                    Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
 300                                "Integer overflow in hexadecimal number");
 301                overflowed = TRUE;
 302                value_nv = (NV) value;
 303            }
 304            value_nv *= 16.0;
 305            /* If an NV has not enough bits in its mantissa to
 306             * represent a UV this summing of small low-order numbers
 307             * is a waste of time (because the NV cannot preserve
 308             * the low-order bits anyway): we could just remember when
 309             * did we overflow and in the end just multiply value_nv by the
 310             * right amount of 16-tuples. */
 311            value_nv += (NV)((hexdigit - PL_hexdigit) & 15);
 312            continue;
 313        }
 314        if (*s == '_' && len && allow_underscores && s[1]
 315                && (hexdigit = strchr(PL_hexdigit, s[1])))
 316            {
 317                --len;
 318                ++s;
 319                goto redo;
 320            }
 321        if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT) && ckWARN(WARN_DIGIT))
 322            Perl_warner(aTHX_ packWARN(WARN_DIGIT),
 323                        "Illegal hexadecimal digit '%c' ignored", *s);
 324        break;
 325    }
 326    
 327    if (   ( overflowed && value_nv > 4294967295.0)
 328#if UVSIZE > 4
 329        || (!overflowed && value > 0xffffffff  )
 330#endif
 331        ) {
 332        if (ckWARN(WARN_PORTABLE))
 333            Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
 334                        "Hexadecimal number > 0xffffffff non-portable");
 335    }
 336    *len_p = s - start;
 337    if (!overflowed) {
 338        *flags = 0;
 339        return value;
 340    }
 341    *flags = PERL_SCAN_GREATER_THAN_UV_MAX;
 342    if (result)
 343        *result = value_nv;
 344    return UV_MAX;
 345}
 346
 347/*
 348=for apidoc grok_oct
 349
 350converts a string representing an octal number to numeric form.
 351
 352On entry I<start> and I<*len> give the string to scan, I<*flags> gives
 353conversion flags, and I<result> should be NULL or a pointer to an NV.
 354The scan stops at the end of the string, or the first invalid character.
 355Unless C<PERL_SCAN_SILENT_ILLDIGIT> is set in I<*flags>, encountering an
 356invalid character will also trigger a warning.
 357On return I<*len> is set to the length of the scanned string,
 358and I<*flags> gives output flags.
 359
 360If the value is <= UV_MAX it is returned as a UV, the output flags are clear,
 361and nothing is written to I<*result>. If the value is > UV_MAX C<grok_oct>
 362returns UV_MAX, sets C<PERL_SCAN_GREATER_THAN_UV_MAX> in the output flags,
 363and writes the value to I<*result> (or the value is discarded if I<result>
 364is NULL).
 365
 366If C<PERL_SCAN_ALLOW_UNDERSCORES> is set in I<*flags> then the octal
 367number may use '_' characters to separate digits.
 368
 369=cut
 370 */
 371
 372UV
 373Perl_grok_oct(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result)
 374{
 375    const char *s = start;
 376    STRLEN len = *len_p;
 377    UV value = 0;
 378    NV value_nv = 0;
 379    const UV max_div_8 = UV_MAX / 8;
 380    const bool allow_underscores = (bool)(*flags & PERL_SCAN_ALLOW_UNDERSCORES);
 381    bool overflowed = FALSE;
 382
 383    PERL_ARGS_ASSERT_GROK_OCT;
 384
 385    for (; len-- && *s; s++) {
 386         /* gcc 2.95 optimiser not smart enough to figure that this subtraction
 387            out front allows slicker code.  */
 388        int digit = *s - '0';
 389        if (digit >= 0 && digit <= 7) {
 390            /* Write it in this wonky order with a goto to attempt to get the
 391               compiler to make the common case integer-only loop pretty tight.
 392            */
 393          redo:
 394            if (!overflowed) {
 395                if (value <= max_div_8) {
 396                    value = (value << 3) | digit;
 397                    continue;
 398                }
 399                /* Bah. We're just overflowed.  */
 400                if (ckWARN_d(WARN_OVERFLOW))
 401                    Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
 402                                "Integer overflow in octal number");
 403                overflowed = TRUE;
 404                value_nv = (NV) value;
 405            }
 406            value_nv *= 8.0;
 407            /* If an NV has not enough bits in its mantissa to
 408             * represent a UV this summing of small low-order numbers
 409             * is a waste of time (because the NV cannot preserve
 410             * the low-order bits anyway): we could just remember when
 411             * did we overflow and in the end just multiply value_nv by the
 412             * right amount of 8-tuples. */
 413            value_nv += (NV)digit;
 414            continue;
 415        }
 416        if (digit == ('_' - '0') && len && allow_underscores
 417            && (digit = s[1] - '0') && (digit >= 0 && digit <= 7))
 418            {
 419                --len;
 420                ++s;
 421                goto redo;
 422            }
 423        /* Allow \octal to work the DWIM way (that is, stop scanning
 424         * as soon as non-octal characters are seen, complain only if
 425         * someone seems to want to use the digits eight and nine). */
 426        if (digit == 8 || digit == 9) {
 427            if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT) && ckWARN(WARN_DIGIT))
 428                Perl_warner(aTHX_ packWARN(WARN_DIGIT),
 429                            "Illegal octal digit '%c' ignored", *s);
 430        }
 431        break;
 432    }
 433    
 434    if (   ( overflowed && value_nv > 4294967295.0)
 435#if UVSIZE > 4
 436        || (!overflowed && value > 0xffffffff  )
 437#endif
 438        ) {
 439        if (ckWARN(WARN_PORTABLE))
 440            Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
 441                        "Octal number > 037777777777 non-portable");
 442    }
 443    *len_p = s - start;
 444    if (!overflowed) {
 445        *flags = 0;
 446        return value;
 447    }
 448    *flags = PERL_SCAN_GREATER_THAN_UV_MAX;
 449    if (result)
 450        *result = value_nv;
 451    return UV_MAX;
 452}
 453
 454/*
 455=for apidoc scan_bin
 456
 457For backwards compatibility. Use C<grok_bin> instead.
 458
 459=for apidoc scan_hex
 460
 461For backwards compatibility. Use C<grok_hex> instead.
 462
 463=for apidoc scan_oct
 464
 465For backwards compatibility. Use C<grok_oct> instead.
 466
 467=cut
 468 */
 469
 470NV
 471Perl_scan_bin(pTHX_ const char *start, STRLEN len, STRLEN *retlen)
 472{
 473    NV rnv;
 474    I32 flags = *retlen ? PERL_SCAN_ALLOW_UNDERSCORES : 0;
 475    const UV ruv = grok_bin (start, &len, &flags, &rnv);
 476
 477    PERL_ARGS_ASSERT_SCAN_BIN;
 478
 479    *retlen = len;
 480    return (flags & PERL_SCAN_GREATER_THAN_UV_MAX) ? rnv : (NV)ruv;
 481}
 482
 483NV
 484Perl_scan_oct(pTHX_ const char *start, STRLEN len, STRLEN *retlen)
 485{
 486    NV rnv;
 487    I32 flags = *retlen ? PERL_SCAN_ALLOW_UNDERSCORES : 0;
 488    const UV ruv = grok_oct (start, &len, &flags, &rnv);
 489
 490    PERL_ARGS_ASSERT_SCAN_OCT;
 491
 492    *retlen = len;
 493    return (flags & PERL_SCAN_GREATER_THAN_UV_MAX) ? rnv : (NV)ruv;
 494}
 495
 496NV
 497Perl_scan_hex(pTHX_ const char *start, STRLEN len, STRLEN *retlen)
 498{
 499    NV rnv;
 500    I32 flags = *retlen ? PERL_SCAN_ALLOW_UNDERSCORES : 0;
 501    const UV ruv = grok_hex (start, &len, &flags, &rnv);
 502
 503    PERL_ARGS_ASSERT_SCAN_HEX;
 504
 505    *retlen = len;
 506    return (flags & PERL_SCAN_GREATER_THAN_UV_MAX) ? rnv : (NV)ruv;
 507}
 508
 509/*
 510=for apidoc grok_numeric_radix
 511
 512Scan and skip for a numeric decimal separator (radix).
 513
 514=cut
 515 */
 516bool
 517Perl_grok_numeric_radix(pTHX_ const char **sp, const char *send)
 518{
 519#ifdef USE_LOCALE_NUMERIC
 520    dVAR;
 521
 522    PERL_ARGS_ASSERT_GROK_NUMERIC_RADIX;
 523
 524    if (PL_numeric_radix_sv && IN_LOCALE) { 
 525        STRLEN len;
 526        const char * const radix = SvPV(PL_numeric_radix_sv, len);
 527        if (*sp + len <= send && memEQ(*sp, radix, len)) {
 528            *sp += len;
 529            return TRUE; 
 530        }
 531    }
 532    /* always try "." if numeric radix didn't match because
 533     * we may have data from different locales mixed */
 534#endif
 535
 536    PERL_ARGS_ASSERT_GROK_NUMERIC_RADIX;
 537
 538    if (*sp < send && **sp == '.') {
 539        ++*sp;
 540        return TRUE;
 541    }
 542    return FALSE;
 543}
 544
 545/*
 546=for apidoc grok_number
 547
 548Recognise (or not) a number.  The type of the number is returned
 549(0 if unrecognised), otherwise it is a bit-ORed combination of
 550IS_NUMBER_IN_UV, IS_NUMBER_GREATER_THAN_UV_MAX, IS_NUMBER_NOT_INT,
 551IS_NUMBER_NEG, IS_NUMBER_INFINITY, IS_NUMBER_NAN (defined in perl.h).
 552
 553If the value of the number can fit an in UV, it is returned in the *valuep
 554IS_NUMBER_IN_UV will be set to indicate that *valuep is valid, IS_NUMBER_IN_UV
 555will never be set unless *valuep is valid, but *valuep may have been assigned
 556to during processing even though IS_NUMBER_IN_UV is not set on return.
 557If valuep is NULL, IS_NUMBER_IN_UV will be set for the same cases as when
 558valuep is non-NULL, but no actual assignment (or SEGV) will occur.
 559
 560IS_NUMBER_NOT_INT will be set with IS_NUMBER_IN_UV if trailing decimals were
 561seen (in which case *valuep gives the true value truncated to an integer), and
 562IS_NUMBER_NEG if the number is negative (in which case *valuep holds the
 563absolute value).  IS_NUMBER_IN_UV is not set if e notation was used or the
 564number is larger than a UV.
 565
 566=cut
 567 */
 568int
 569Perl_grok_number(pTHX_ const char *pv, STRLEN len, UV *valuep)
 570{
 571  const char *s = pv;
 572  const char * const send = pv + len;
 573  const UV max_div_10 = UV_MAX / 10;
 574  const char max_mod_10 = UV_MAX % 10;
 575  int numtype = 0;
 576  int sawinf = 0;
 577  int sawnan = 0;
 578
 579  PERL_ARGS_ASSERT_GROK_NUMBER;
 580
 581  while (s < send && isSPACE(*s))
 582    s++;
 583  if (s == send) {
 584    return 0;
 585  } else if (*s == '-') {
 586    s++;
 587    numtype = IS_NUMBER_NEG;
 588  }
 589  else if (*s == '+')
 590  s++;
 591
 592  if (s == send)
 593    return 0;
 594
 595  /* next must be digit or the radix separator or beginning of infinity */
 596  if (isDIGIT(*s)) {
 597    /* UVs are at least 32 bits, so the first 9 decimal digits cannot
 598       overflow.  */
 599    UV value = *s - '0';
 600    /* This construction seems to be more optimiser friendly.
 601       (without it gcc does the isDIGIT test and the *s - '0' separately)
 602       With it gcc on arm is managing 6 instructions (6 cycles) per digit.
 603       In theory the optimiser could deduce how far to unroll the loop
 604       before checking for overflow.  */
 605    if (++s < send) {
 606      int digit = *s - '0';
 607      if (digit >= 0 && digit <= 9) {
 608        value = value * 10 + digit;
 609        if (++s < send) {
 610          digit = *s - '0';
 611          if (digit >= 0 && digit <= 9) {
 612            value = value * 10 + digit;
 613            if (++s < send) {
 614              digit = *s - '0';
 615              if (digit >= 0 && digit <= 9) {
 616                value = value * 10 + digit;
 617                if (++s < send) {
 618                  digit = *s - '0';
 619                  if (digit >= 0 && digit <= 9) {
 620                    value = value * 10 + digit;
 621                    if (++s < send) {
 622                      digit = *s - '0';
 623                      if (digit >= 0 && digit <= 9) {
 624                        value = value * 10 + digit;
 625                        if (++s < send) {
 626                          digit = *s - '0';
 627                          if (digit >= 0 && digit <= 9) {
 628                            value = value * 10 + digit;
 629                            if (++s < send) {
 630                              digit = *s - '0';
 631                              if (digit >= 0 && digit <= 9) {
 632                                value = value * 10 + digit;
 633                                if (++s < send) {
 634                                  digit = *s - '0';
 635                                  if (digit >= 0 && digit <= 9) {
 636                                    value = value * 10 + digit;
 637                                    if (++s < send) {
 638                                      /* Now got 9 digits, so need to check
 639                                         each time for overflow.  */
 640                                      digit = *s - '0';
 641                                      while (digit >= 0 && digit <= 9
 642                                             && (value < max_div_10
 643                                                 || (value == max_div_10
 644                                                     && digit <= max_mod_10))) {
 645                                        value = value * 10 + digit;
 646                                        if (++s < send)
 647                                          digit = *s - '0';
 648                                        else
 649                                          break;
 650                                      }
 651                                      if (digit >= 0 && digit <= 9
 652                                          && (s < send)) {
 653                                        /* value overflowed.
 654                                           skip the remaining digits, don't
 655                                           worry about setting *valuep.  */
 656                                        do {
 657                                          s++;
 658                                        } while (s < send && isDIGIT(*s));
 659                                        numtype |=
 660                                          IS_NUMBER_GREATER_THAN_UV_MAX;
 661                                        goto skip_value;
 662                                      }
 663                                    }
 664                                  }
 665                                }
 666                              }
 667                            }
 668                          }
 669                        }
 670                      }
 671                    }
 672                  }
 673                }
 674              }
 675            }
 676          }
 677        }
 678      }
 679    }
 680    numtype |= IS_NUMBER_IN_UV;
 681    if (valuep)
 682      *valuep = value;
 683
 684  skip_value:
 685    if (GROK_NUMERIC_RADIX(&s, send)) {
 686      numtype |= IS_NUMBER_NOT_INT;
 687      while (s < send && isDIGIT(*s))  /* optional digits after the radix */
 688        s++;
 689    }
 690  }
 691  else if (GROK_NUMERIC_RADIX(&s, send)) {
 692    numtype |= IS_NUMBER_NOT_INT | IS_NUMBER_IN_UV; /* valuep assigned below */
 693    /* no digits before the radix means we need digits after it */
 694    if (s < send && isDIGIT(*s)) {
 695      do {
 696        s++;
 697      } while (s < send && isDIGIT(*s));
 698      if (valuep) {
 699        /* integer approximation is valid - it's 0.  */
 700        *valuep = 0;
 701      }
 702    }
 703    else
 704      return 0;
 705  } else if (*s == 'I' || *s == 'i') {
 706    s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
 707    s++; if (s == send || (*s != 'F' && *s != 'f')) return 0;
 708    s++; if (s < send && (*s == 'I' || *s == 'i')) {
 709      s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
 710      s++; if (s == send || (*s != 'I' && *s != 'i')) return 0;
 711      s++; if (s == send || (*s != 'T' && *s != 't')) return 0;
 712      s++; if (s == send || (*s != 'Y' && *s != 'y')) return 0;
 713      s++;
 714    }
 715    sawinf = 1;
 716  } else if (*s == 'N' || *s == 'n') {
 717    /* XXX TODO: There are signaling NaNs and quiet NaNs. */
 718    s++; if (s == send || (*s != 'A' && *s != 'a')) return 0;
 719    s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
 720    s++;
 721    sawnan = 1;
 722  } else
 723    return 0;
 724
 725  if (sawinf) {
 726    numtype &= IS_NUMBER_NEG; /* Keep track of sign  */
 727    numtype |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT;
 728  } else if (sawnan) {
 729    numtype &= IS_NUMBER_NEG; /* Keep track of sign  */
 730    numtype |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT;
 731  } else if (s < send) {
 732    /* we can have an optional exponent part */
 733    if (*s == 'e' || *s == 'E') {
 734      /* The only flag we keep is sign.  Blow away any "it's UV"  */
 735      numtype &= IS_NUMBER_NEG;
 736      numtype |= IS_NUMBER_NOT_INT;
 737      s++;
 738      if (s < send && (*s == '-' || *s == '+'))
 739        s++;
 740      if (s < send && isDIGIT(*s)) {
 741        do {
 742          s++;
 743        } while (s < send && isDIGIT(*s));
 744      }
 745      else
 746      return 0;
 747    }
 748  }
 749  while (s < send && isSPACE(*s))
 750    s++;
 751  if (s >= send)
 752    return numtype;
 753  if (len == 10 && memEQ(pv, "0 but true", 10)) {
 754    if (valuep)
 755      *valuep = 0;
 756    return IS_NUMBER_IN_UV;
 757  }
 758  return 0;
 759}
 760
 761STATIC NV
 762S_mulexp10(NV value, I32 exponent)
 763{
 764    NV result = 1.0;
 765    NV power = 10.0;
 766    bool negative = 0;
 767    I32 bit;
 768
 769    if (exponent == 0)
 770        return value;
 771    if (value == 0)
 772        return (NV)0;
 773
 774    /* On OpenVMS VAX we by default use the D_FLOAT double format,
 775     * and that format does not have *easy* capabilities [1] for
 776     * overflowing doubles 'silently' as IEEE fp does.  We also need 
 777     * to support G_FLOAT on both VAX and Alpha, and though the exponent 
 778     * range is much larger than D_FLOAT it still doesn't do silent 
 779     * overflow.  Therefore we need to detect early whether we would 
 780     * overflow (this is the behaviour of the native string-to-float 
 781     * conversion routines, and therefore of native applications, too).
 782     *
 783     * [1] Trying to establish a condition handler to trap floating point
 784     *     exceptions is not a good idea. */
 785
 786    /* In UNICOS and in certain Cray models (such as T90) there is no
 787     * IEEE fp, and no way at all from C to catch fp overflows gracefully.
 788     * There is something you can do if you are willing to use some
 789     * inline assembler: the instruction is called DFI-- but that will
 790     * disable *all* floating point interrupts, a little bit too large
 791     * a hammer.  Therefore we need to catch potential overflows before
 792     * it's too late. */
 793
 794#if ((defined(VMS) && !defined(__IEEE_FP)) || defined(_UNICOS)) && defined(NV_MAX_10_EXP)
 795    STMT_START {
 796        const NV exp_v = log10(value);
 797        if (exponent >= NV_MAX_10_EXP || exponent + exp_v >= NV_MAX_10_EXP)
 798            return NV_MAX;
 799        if (exponent < 0) {
 800            if (-(exponent + exp_v) >= NV_MAX_10_EXP)
 801                return 0.0;
 802            while (-exponent >= NV_MAX_10_EXP) {
 803                /* combination does not overflow, but 10^(-exponent) does */
 804                value /= 10;
 805                ++exponent;
 806            }
 807        }
 808    } STMT_END;
 809#endif
 810
 811    if (exponent < 0) {
 812        negative = 1;
 813        exponent = -exponent;
 814    }
 815    for (bit = 1; exponent; bit <<= 1) {
 816        if (exponent & bit) {
 817            exponent ^= bit;
 818            result *= power;
 819            /* Floating point exceptions are supposed to be turned off,
 820             *  but if we're obviously done, don't risk another iteration.  
 821             */
 822             if (exponent == 0) break;
 823        }
 824        power *= power;
 825    }
 826    return negative ? value / result : value * result;
 827}
 828
 829NV
 830Perl_my_atof(pTHX_ const char* s)
 831{
 832    NV x = 0.0;
 833#ifdef USE_LOCALE_NUMERIC
 834    dVAR;
 835
 836    PERL_ARGS_ASSERT_MY_ATOF;
 837
 838    if (PL_numeric_local && IN_LOCALE) {
 839        NV y;
 840
 841        /* Scan the number twice; once using locale and once without;
 842         * choose the larger result (in absolute value). */
 843        Perl_atof2(s, x);
 844        SET_NUMERIC_STANDARD();
 845        Perl_atof2(s, y);
 846        SET_NUMERIC_LOCAL();
 847        if ((y < 0.0 && y < x) || (y > 0.0 && y > x))
 848            return y;
 849    }
 850    else
 851        Perl_atof2(s, x);
 852#else
 853    Perl_atof2(s, x);
 854#endif
 855    return x;
 856}
 857
 858char*
 859Perl_my_atof2(pTHX_ const char* orig, NV* value)
 860{
 861    NV result[3] = {0.0, 0.0, 0.0};
 862    const char* s = orig;
 863#ifdef USE_PERL_ATOF
 864    UV accumulator[2] = {0,0};  /* before/after dp */
 865    bool negative = 0;
 866    const char* send = s + strlen(orig) - 1;
 867    bool seen_digit = 0;
 868    I32 exp_adjust[2] = {0,0};
 869    I32 exp_acc[2] = {-1, -1};
 870    /* the current exponent adjust for the accumulators */
 871    I32 exponent = 0;
 872    I32 seen_dp  = 0;
 873    I32 digit = 0;
 874    I32 old_digit = 0;
 875    I32 sig_digits = 0; /* noof significant digits seen so far */
 876
 877    PERL_ARGS_ASSERT_MY_ATOF2;
 878
 879/* There is no point in processing more significant digits
 880 * than the NV can hold. Note that NV_DIG is a lower-bound value,
 881 * while we need an upper-bound value. We add 2 to account for this;
 882 * since it will have been conservative on both the first and last digit.
 883 * For example a 32-bit mantissa with an exponent of 4 would have
 884 * exact values in the set
 885 *               4
 886 *               8
 887 *              ..
 888 *     17179869172
 889 *     17179869176
 890 *     17179869180
 891 *
 892 * where for the purposes of calculating NV_DIG we would have to discount
 893 * both the first and last digit, since neither can hold all values from
 894 * 0..9; but for calculating the value we must examine those two digits.
 895 */
 896#define MAX_SIG_DIGITS (NV_DIG+2)
 897
 898/* the max number we can accumulate in a UV, and still safely do 10*N+9 */
 899#define MAX_ACCUMULATE ( (UV) ((UV_MAX - 9)/10))
 900
 901    /* leading whitespace */
 902    while (isSPACE(*s))
 903        ++s;
 904
 905    /* sign */
 906    switch (*s) {
 907        case '-':
 908            negative = 1;
 909            /* fall through */
 910        case '+':
 911            ++s;
 912    }
 913
 914    /* punt to strtod for NaN/Inf; if no support for it there, tough luck */
 915
 916#ifdef HAS_STRTOD
 917    if (*s == 'n' || *s == 'N' || *s == 'i' || *s == 'I') {
 918        const char *p = negative ? s - 1 : s;
 919        char *endp;
 920        NV rslt;
 921        rslt = strtod(p, &endp);
 922        if (endp != p) {
 923            *value = rslt;
 924            return (char *)endp;
 925        }
 926    }
 927#endif
 928
 929    /* we accumulate digits into an integer; when this becomes too
 930     * large, we add the total to NV and start again */
 931
 932    while (1) {
 933        if (isDIGIT(*s)) {
 934            seen_digit = 1;
 935            old_digit = digit;
 936            digit = *s++ - '0';
 937            if (seen_dp)
 938                exp_adjust[1]++;
 939
 940            /* don't start counting until we see the first significant
 941             * digit, eg the 5 in 0.00005... */
 942            if (!sig_digits && digit == 0)
 943                continue;
 944
 945            if (++sig_digits > MAX_SIG_DIGITS) {
 946                /* limits of precision reached */
 947                if (digit > 5) {
 948                    ++accumulator[seen_dp];
 949                } else if (digit == 5) {
 950                    if (old_digit % 2) { /* round to even - Allen */
 951                        ++accumulator[seen_dp];
 952                    }
 953                }
 954                if (seen_dp) {
 955                    exp_adjust[1]--;
 956                } else {
 957                    exp_adjust[0]++;
 958                }
 959                /* skip remaining digits */
 960                while (isDIGIT(*s)) {
 961                    ++s;
 962                    if (! seen_dp) {
 963                        exp_adjust[0]++;
 964                    }
 965                }
 966                /* warn of loss of precision? */
 967            }
 968            else {
 969                if (accumulator[seen_dp] > MAX_ACCUMULATE) {
 970                    /* add accumulator to result and start again */
 971                    result[seen_dp] = S_mulexp10(result[seen_dp],
 972                                                 exp_acc[seen_dp])
 973                        + (NV)accumulator[seen_dp];
 974                    accumulator[seen_dp] = 0;
 975                    exp_acc[seen_dp] = 0;
 976                }
 977                accumulator[seen_dp] = accumulator[seen_dp] * 10 + digit;
 978                ++exp_acc[seen_dp];
 979            }
 980        }
 981        else if (!seen_dp && GROK_NUMERIC_RADIX(&s, send)) {
 982            seen_dp = 1;
 983            if (sig_digits > MAX_SIG_DIGITS) {
 984                do {
 985                    ++s;
 986                } while (isDIGIT(*s));
 987                break;
 988            }
 989        }
 990        else {
 991            break;
 992        }
 993    }
 994
 995    result[0] = S_mulexp10(result[0], exp_acc[0]) + (NV)accumulator[0];
 996    if (seen_dp) {
 997        result[1] = S_mulexp10(result[1], exp_acc[1]) + (NV)accumulator[1];
 998    }
 999
1000    if (seen_digit && (*s == 'e' || *s == 'E')) {
1001        bool expnegative = 0;
1002
1003        ++s;
1004        switch (*s) {
1005            case '-':
1006                expnegative = 1;
1007                /* fall through */
1008            case '+':
1009                ++s;
1010        }
1011        while (isDIGIT(*s))
1012            exponent = exponent * 10 + (*s++ - '0');
1013        if (expnegative)
1014            exponent = -exponent;
1015    }
1016
1017
1018
1019    /* now apply the exponent */
1020
1021    if (seen_dp) {
1022        result[2] = S_mulexp10(result[0],exponent+exp_adjust[0])
1023                + S_mulexp10(result[1],exponent-exp_adjust[1]);
1024    } else {
1025        result[2] = S_mulexp10(result[0],exponent+exp_adjust[0]);
1026    }
1027
1028    /* now apply the sign */
1029    if (negative)
1030        result[2] = -result[2];
1031#endif /* USE_PERL_ATOF */
1032    *value = result[2];
1033    return (char *)s;
1034}
1035
1036#if ! defined(HAS_MODFL) && defined(HAS_AINTL) && defined(HAS_COPYSIGNL)
1037long double
1038Perl_my_modfl(long double x, long double *ip)
1039{
1040        *ip = aintl(x);
1041        return (x == *ip ? copysignl(0.0L, x) : x - *ip);
1042}
1043#endif
1044
1045#if ! defined(HAS_FREXPL) && defined(HAS_ILOGBL) && defined(HAS_SCALBNL)
1046long double
1047Perl_my_frexpl(long double x, int *e) {
1048        *e = x == 0.0L ? 0 : ilogbl(x) + 1;
1049        return (scalbnl(x, -*e));
1050}
1051#endif
1052
1053/*
1054=for apidoc Perl_signbit
1055
1056Return a non-zero integer if the sign bit on an NV is set, and 0 if
1057it is not.  
1058
1059If Configure detects this system has a signbit() that will work with
1060our NVs, then we just use it via the #define in perl.h.  Otherwise,
1061fall back on this implementation.  As a first pass, this gets everything
1062right except -0.0.  Alas, catching -0.0 is the main use for this function,
1063so this is not too helpful yet.  Still, at least we have the scaffolding
1064in place to support other systems, should that prove useful.
1065
1066
1067Configure notes:  This function is called 'Perl_signbit' instead of a
1068plain 'signbit' because it is easy to imagine a system having a signbit()
1069function or macro that doesn't happen to work with our particular choice
1070of NVs.  We shouldn't just re-#define signbit as Perl_signbit and expect
1071the standard system headers to be happy.  Also, this is a no-context
1072function (no pTHX_) because Perl_signbit() is usually re-#defined in
1073perl.h as a simple macro call to the system's signbit().
1074Users should just always call Perl_signbit().
1075
1076=cut
1077*/
1078#if !defined(HAS_SIGNBIT)
1079int
1080Perl_signbit(NV x) {
1081    return (x < 0.0) ? 1 : 0;
1082}
1083#endif
1084
1085/*
1086 * Local variables:
1087 * c-indentation-style: bsd
1088 * c-basic-offset: 4
1089 * indent-tabs-mode: t
1090 * End:
1091 *
1092 * ex: set ts=8 sts=4 sw=4 noet:
1093 */
1094
lxr.linux.no kindly hosted by Redpill Linpro AS, provider of Linux consulting and operations services since 1995.