| Commit | Line | Data |
|---|
| 98994639 |
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 |
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 |
367 | |
| 368 | =cut |
| 369 | */ |
| 370 | int |
| 371 | Perl_grok_number(pTHX_ const char *pv, STRLEN len, UV *valuep) |
| 372 | { |
| 60939fb8 |
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. */ |
| 404 | if (s < send) { |
| 405 | int digit = *++s - '0'; |
| 406 | if (digit >= 0 && digit <= 9) { |
| 407 | value = value * 10 + digit; |
| 408 | if (s < send) { |
| 409 | digit = *++s - '0'; |
| 410 | if (digit >= 0 && digit <= 9) { |
| 411 | value = value * 10 + digit; |
| 412 | if (s < send) { |
| 413 | digit = *++s - '0'; |
| 414 | if (digit >= 0 && digit <= 9) { |
| 415 | value = value * 10 + digit; |
| 416 | if (s < send) { |
| 417 | digit = *++s - '0'; |
| 418 | if (digit >= 0 && digit <= 9) { |
| 419 | value = value * 10 + digit; |
| 420 | if (s < send) { |
| 421 | digit = *++s - '0'; |
| 422 | if (digit >= 0 && digit <= 9) { |
| 423 | value = value * 10 + digit; |
| 424 | if (s < send) { |
| 425 | digit = *++s - '0'; |
| 426 | if (digit >= 0 && digit <= 9) { |
| 427 | value = value * 10 + digit; |
| 428 | if (s < send) { |
| 429 | digit = *++s - '0'; |
| 430 | if (digit >= 0 && digit <= 9) { |
| 431 | value = value * 10 + digit; |
| 432 | if (s < send) { |
| 433 | digit = *++s - '0'; |
| 434 | if (digit >= 0 && digit <= 9) { |
| 435 | value = value * 10 + digit; |
| 436 | if (s < send) { |
| 437 | /* Now got 9 digits, so need to check |
| 438 | each time for overflow. */ |
| 439 | digit = *++s - '0'; |
| 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; |
| 445 | if (s < send) |
| 446 | digit = *++s - '0'; |
| 447 | else |
| 448 | break; |
| 449 | } |
| 450 | if (digit >= 0 && digit <= 9 |
| 451 | && !(s < send)) { |
| 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 |
465 | } |
| 466 | } |
| 467 | } |
| 468 | } |
| 469 | } |
| 470 | } |
| 471 | } |
| 472 | } |
| 473 | } |
| 474 | } |
| 475 | } |
| 98994639 |
476 | } |
| 60939fb8 |
477 | } |
| 98994639 |
478 | } |
| 60939fb8 |
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 |
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 |
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 |
514 | sawinf = 1; |
| 515 | } else /* Add test for NaN here. */ |
| 98994639 |
516 | return 0; |
| 60939fb8 |
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 |
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 |
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 |
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 | |
| 632 | /* sign */ |
| 633 | switch (*s) { |
| 634 | case '-': |
| 635 | negative = 1; |
| 636 | /* fall through */ |
| 637 | case '+': |
| 638 | ++s; |
| 639 | } |
| 640 | |
| 641 | part[0] = offcount = 0; |
| 642 | if (isDIGIT(*s)) { |
| 643 | seendigit = 1; /* get this over with */ |
| 644 | |
| 645 | /* skip leading zeros */ |
| 646 | while (*s == '0') |
| 647 | ++s; |
| 648 | } |
| 649 | |
| 650 | /* integer digits */ |
| 651 | while (isDIGIT(*s)) { |
| 652 | if (++offcount > PARTSIZE) { |
| 653 | if (++ipart < PARTLIM) { |
| 654 | part[ipart] = 0; |
| 655 | offcount = 1; /* ++0 */ |
| 656 | } |
| 657 | else { |
| 658 | /* limits of precision reached */ |
| 659 | --ipart; |
| 660 | --offcount; |
| 661 | if (*s >= '5') |
| 662 | ++part[ipart]; |
| 663 | while (isDIGIT(*s)) { |
| 664 | ++expextra; |
| 665 | ++s; |
| 666 | } |
| 667 | /* warn of loss of precision? */ |
| 668 | break; |
| 669 | } |
| 670 | } |
| 671 | part[ipart] = part[ipart] * 10 + (*s++ - '0'); |
| 672 | } |
| 673 | |
| 674 | /* decimal point */ |
| 675 | if (GROK_NUMERIC_RADIX((const char **)&s, send)) { |
| 676 | if (isDIGIT(*s)) |
| 677 | seendigit = 1; /* get this over with */ |
| 678 | |
| 679 | /* decimal digits */ |
| 680 | while (isDIGIT(*s)) { |
| 681 | if (++offcount > PARTSIZE) { |
| 682 | if (++ipart < PARTLIM) { |
| 683 | part[ipart] = 0; |
| 684 | offcount = 1; /* ++0 */ |
| 685 | } |
| 686 | else { |
| 687 | /* limits of precision reached */ |
| 688 | --ipart; |
| 689 | --offcount; |
| 690 | if (*s >= '5') |
| 691 | ++part[ipart]; |
| 692 | while (isDIGIT(*s)) |
| 693 | ++s; |
| 694 | /* warn of loss of precision? */ |
| 695 | break; |
| 696 | } |
| 697 | } |
| 698 | --expextra; |
| 699 | part[ipart] = part[ipart] * 10 + (*s++ - '0'); |
| 700 | } |
| 701 | } |
| 702 | |
| 703 | /* combine components of mantissa */ |
| 704 | for (i = 0; i <= ipart; ++i) |
| 705 | result += S_mulexp10((NV)part[ipart - i], |
| 706 | i ? offcount + (i - 1) * PARTSIZE : 0); |
| 707 | |
| 708 | if (seendigit && (*s == 'e' || *s == 'E')) { |
| 709 | bool expnegative = 0; |
| 710 | |
| 711 | ++s; |
| 712 | switch (*s) { |
| 713 | case '-': |
| 714 | expnegative = 1; |
| 715 | /* fall through */ |
| 716 | case '+': |
| 717 | ++s; |
| 718 | } |
| 719 | while (isDIGIT(*s)) |
| 720 | exponent = exponent * 10 + (*s++ - '0'); |
| 721 | if (expnegative) |
| 722 | exponent = -exponent; |
| 723 | } |
| 724 | |
| 725 | /* now apply the exponent */ |
| 726 | exponent += expextra; |
| 727 | result = S_mulexp10(result, exponent); |
| 728 | |
| 729 | /* now apply the sign */ |
| 730 | if (negative) |
| 731 | result = -result; |
| 732 | *value = result; |
| 733 | return s; |
| 734 | } |
| 735 | |
projects / p5sagit/p5-mst-13.2.git / blame