Remove Encode::Tcl::Extended, suggested by
[p5sagit/p5-mst-13.2.git] / numeric.c
CommitLineData
98994639 1/* numeric.c
2 *
be3c0a43 3 * Copyright (c) 2001-2002, Larry Wall
98994639 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
ccfc67b7 15/*
16=head1 Numeric functions
17*/
18
98994639 19#include "EXTERN.h"
20#define PERL_IN_NUMERIC_C
21#include "perl.h"
22
23U32
24Perl_cast_ulong(pTHX_ NV f)
25{
26 if (f < 0.0)
27 return f < I32_MIN ? (U32) I32_MIN : (U32)(I32) f;
28 if (f < U32_MAX_P1) {
29#if CASTFLAGS & 2
30 if (f < U32_MAX_P1_HALF)
31 return (U32) f;
32 f -= U32_MAX_P1_HALF;
33 return ((U32) f) | (1 + U32_MAX >> 1);
34#else
35 return (U32) f;
36#endif
37 }
38 return f > 0 ? U32_MAX : 0 /* NaN */;
39}
40
41I32
42Perl_cast_i32(pTHX_ NV f)
43{
44 if (f < I32_MAX_P1)
45 return f < I32_MIN ? I32_MIN : (I32) f;
46 if (f < U32_MAX_P1) {
47#if CASTFLAGS & 2
48 if (f < U32_MAX_P1_HALF)
49 return (I32)(U32) f;
50 f -= U32_MAX_P1_HALF;
51 return (I32)(((U32) f) | (1 + U32_MAX >> 1));
52#else
53 return (I32)(U32) f;
54#endif
55 }
56 return f > 0 ? (I32)U32_MAX : 0 /* NaN */;
57}
58
59IV
60Perl_cast_iv(pTHX_ NV f)
61{
62 if (f < IV_MAX_P1)
63 return f < IV_MIN ? IV_MIN : (IV) f;
64 if (f < UV_MAX_P1) {
65#if CASTFLAGS & 2
66 /* For future flexibility allowing for sizeof(UV) >= sizeof(IV) */
67 if (f < UV_MAX_P1_HALF)
68 return (IV)(UV) f;
69 f -= UV_MAX_P1_HALF;
70 return (IV)(((UV) f) | (1 + UV_MAX >> 1));
71#else
72 return (IV)(UV) f;
73#endif
74 }
75 return f > 0 ? (IV)UV_MAX : 0 /* NaN */;
76}
77
78UV
79Perl_cast_uv(pTHX_ NV f)
80{
81 if (f < 0.0)
82 return f < IV_MIN ? (UV) IV_MIN : (UV)(IV) f;
83 if (f < UV_MAX_P1) {
84#if CASTFLAGS & 2
85 if (f < UV_MAX_P1_HALF)
86 return (UV) f;
87 f -= UV_MAX_P1_HALF;
88 return ((UV) f) | (1 + UV_MAX >> 1);
89#else
90 return (UV) f;
91#endif
92 }
93 return f > 0 ? UV_MAX : 0 /* NaN */;
94}
95
96#if defined(HUGE_VAL) || (defined(USE_LONG_DOUBLE) && defined(HUGE_VALL))
97/*
98 * This hack is to force load of "huge" support from libm.a
99 * So it is in perl for (say) POSIX to use.
100 * Needed for SunOS with Sun's 'acc' for example.
101 */
102NV
103Perl_huge(void)
104{
105# if defined(USE_LONG_DOUBLE) && defined(HUGE_VALL)
106 return HUGE_VALL;
107# endif
108 return HUGE_VAL;
109}
110#endif
111
53305cf1 112/*
113=for apidoc grok_bin
98994639 114
53305cf1 115converts a string representing a binary number to numeric form.
116
117On entry I<start> and I<*len> give the string to scan, I<*flags> gives
118conversion flags, and I<result> should be NULL or a pointer to an NV.
119The scan stops at the end of the string, or the first invalid character.
120On return I<*len> is set to the length scanned string, and I<*flags> gives
121output flags.
122
123If the value is <= UV_MAX it is returned as a UV, the output flags are clear,
124and nothing is written to I<*result>. If the value is > UV_MAX C<grok_bin>
125returns UV_MAX, sets C<PERL_SCAN_GREATER_THAN_UV_MAX> in the output flags,
126and writes the value to I<*result> (or the value is discarded if I<result>
127is NULL).
128
d1be9408 129The hex number may optionally be prefixed with "0b" or "b" unless
a4c04bdc 130C<PERL_SCAN_DISALLOW_PREFIX> is set in I<*flags> on entry. If
131C<PERL_SCAN_ALLOW_UNDERSCORES> is set in I<*flags> then the binary
53305cf1 132number may use '_' characters to separate digits.
133
134=cut
135 */
136
137UV
138Perl_grok_bin(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result) {
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 bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES;
146 bool overflowed = FALSE;
147
a4c04bdc 148 if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) {
149 /* strip off leading b or 0b.
150 for compatibility silently suffer "b" and "0b" as valid binary
151 numbers. */
152 if (len >= 1) {
153 if (s[0] == 'b') {
154 s++;
155 len--;
156 }
157 else if (len >= 2 && s[0] == '0' && s[1] == 'b') {
158 s+=2;
159 len-=2;
160 }
161 }
53305cf1 162 }
163
164 for (; len-- && *s; s++) {
165 char bit = *s;
166 if (bit == '0' || bit == '1') {
167 /* Write it in this wonky order with a goto to attempt to get the
168 compiler to make the common case integer-only loop pretty tight.
169 With gcc seems to be much straighter code than old scan_bin. */
170 redo:
171 if (!overflowed) {
172 if (value <= max_div_2) {
173 value = (value << 1) | (bit - '0');
174 continue;
175 }
176 /* Bah. We're just overflowed. */
177 if (ckWARN_d(WARN_OVERFLOW))
9014280d 178 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
53305cf1 179 "Integer overflow in binary number");
180 overflowed = TRUE;
181 value_nv = (NV) value;
182 }
183 value_nv *= 2.0;
98994639 184 /* If an NV has not enough bits in its mantissa to
d1be9408 185 * represent a UV this summing of small low-order numbers
98994639 186 * is a waste of time (because the NV cannot preserve
187 * the low-order bits anyway): we could just remember when
53305cf1 188 * did we overflow and in the end just multiply value_nv by the
98994639 189 * right amount. */
53305cf1 190 value_nv += (NV)(bit - '0');
191 continue;
192 }
193 if (bit == '_' && len && allow_underscores && (bit = s[1])
194 && (bit == '0' || bit == '1'))
98994639 195 {
196 --len;
197 ++s;
53305cf1 198 goto redo;
98994639 199 }
53305cf1 200 if (ckWARN(WARN_DIGIT))
9014280d 201 Perl_warner(aTHX_ packWARN(WARN_DIGIT),
53305cf1 202 "Illegal binary digit '%c' ignored", *s);
203 break;
98994639 204 }
53305cf1 205
206 if ( ( overflowed && value_nv > 4294967295.0)
98994639 207#if UVSIZE > 4
53305cf1 208 || (!overflowed && value > 0xffffffff )
98994639 209#endif
210 ) {
211 if (ckWARN(WARN_PORTABLE))
9014280d 212 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
53305cf1 213 "Binary number > 0b11111111111111111111111111111111 non-portable");
214 }
215 *len_p = s - start;
216 if (!overflowed) {
217 *flags = 0;
218 return value;
98994639 219 }
53305cf1 220 *flags = PERL_SCAN_GREATER_THAN_UV_MAX;
221 if (result)
222 *result = value_nv;
223 return UV_MAX;
98994639 224}
225
53305cf1 226/*
227=for apidoc grok_hex
228
229converts a string representing a hex number to numeric form.
230
231On entry I<start> and I<*len> give the string to scan, I<*flags> gives
232conversion flags, and I<result> should be NULL or a pointer to an NV.
233The scan stops at the end of the string, or the first non-hex-digit character.
234On return I<*len> is set to the length scanned string, and I<*flags> gives
235output flags.
236
237If the value is <= UV_MAX it is returned as a UV, the output flags are clear,
238and nothing is written to I<*result>. If the value is > UV_MAX C<grok_hex>
239returns UV_MAX, sets C<PERL_SCAN_GREATER_THAN_UV_MAX> in the output flags,
240and writes the value to I<*result> (or the value is discarded if I<result>
241is NULL).
242
d1be9408 243The hex number may optionally be prefixed with "0x" or "x" unless
a4c04bdc 244C<PERL_SCAN_DISALLOW_PREFIX> is set in I<*flags> on entry. If
245C<PERL_SCAN_ALLOW_UNDERSCORES> is set in I<*flags> then the hex
53305cf1 246number may use '_' characters to separate digits.
247
248=cut
249 */
250
251UV
252Perl_grok_hex(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result) {
253 const char *s = start;
254 STRLEN len = *len_p;
255 UV value = 0;
256 NV value_nv = 0;
257
258 const UV max_div_16 = UV_MAX / 16;
259 bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES;
260 bool overflowed = FALSE;
261 const char *hexdigit;
98994639 262
a4c04bdc 263 if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) {
264 /* strip off leading x or 0x.
265 for compatibility silently suffer "x" and "0x" as valid hex numbers.
266 */
267 if (len >= 1) {
268 if (s[0] == 'x') {
269 s++;
270 len--;
271 }
272 else if (len >= 2 && s[0] == '0' && s[1] == 'x') {
273 s+=2;
274 len-=2;
275 }
276 }
98994639 277 }
278
279 for (; len-- && *s; s++) {
280 hexdigit = strchr((char *) PL_hexdigit, *s);
53305cf1 281 if (hexdigit) {
282 /* Write it in this wonky order with a goto to attempt to get the
283 compiler to make the common case integer-only loop pretty tight.
284 With gcc seems to be much straighter code than old scan_hex. */
285 redo:
286 if (!overflowed) {
287 if (value <= max_div_16) {
288 value = (value << 4) | ((hexdigit - PL_hexdigit) & 15);
289 continue;
290 }
291 /* Bah. We're just overflowed. */
292 if (ckWARN_d(WARN_OVERFLOW))
9014280d 293 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
53305cf1 294 "Integer overflow in hexadecimal number");
295 overflowed = TRUE;
296 value_nv = (NV) value;
297 }
298 value_nv *= 16.0;
299 /* If an NV has not enough bits in its mantissa to
d1be9408 300 * represent a UV this summing of small low-order numbers
53305cf1 301 * is a waste of time (because the NV cannot preserve
302 * the low-order bits anyway): we could just remember when
303 * did we overflow and in the end just multiply value_nv by the
304 * right amount of 16-tuples. */
305 value_nv += (NV)((hexdigit - PL_hexdigit) & 15);
306 continue;
307 }
308 if (*s == '_' && len && allow_underscores && s[1]
98994639 309 && (hexdigit = strchr((char *) PL_hexdigit, s[1])))
310 {
311 --len;
312 ++s;
53305cf1 313 goto redo;
98994639 314 }
53305cf1 315 if (ckWARN(WARN_DIGIT))
9014280d 316 Perl_warner(aTHX_ packWARN(WARN_DIGIT),
53305cf1 317 "Illegal hexadecimal digit '%c' ignored", *s);
318 break;
319 }
320
321 if ( ( overflowed && value_nv > 4294967295.0)
322#if UVSIZE > 4
323 || (!overflowed && value > 0xffffffff )
324#endif
325 ) {
326 if (ckWARN(WARN_PORTABLE))
9014280d 327 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
53305cf1 328 "Hexadecimal number > 0xffffffff non-portable");
329 }
330 *len_p = s - start;
331 if (!overflowed) {
332 *flags = 0;
333 return value;
334 }
335 *flags = PERL_SCAN_GREATER_THAN_UV_MAX;
336 if (result)
337 *result = value_nv;
338 return UV_MAX;
339}
340
341/*
342=for apidoc grok_oct
343
344
345=cut
346 */
347
348UV
349Perl_grok_oct(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result) {
350 const char *s = start;
351 STRLEN len = *len_p;
352 UV value = 0;
353 NV value_nv = 0;
354
355 const UV max_div_8 = UV_MAX / 8;
356 bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES;
357 bool overflowed = FALSE;
358
359 for (; len-- && *s; s++) {
360 /* gcc 2.95 optimiser not smart enough to figure that this subtraction
361 out front allows slicker code. */
362 int digit = *s - '0';
363 if (digit >= 0 && digit <= 7) {
364 /* Write it in this wonky order with a goto to attempt to get the
365 compiler to make the common case integer-only loop pretty tight.
366 */
367 redo:
368 if (!overflowed) {
369 if (value <= max_div_8) {
370 value = (value << 3) | digit;
371 continue;
372 }
373 /* Bah. We're just overflowed. */
374 if (ckWARN_d(WARN_OVERFLOW))
9014280d 375 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
53305cf1 376 "Integer overflow in octal number");
377 overflowed = TRUE;
378 value_nv = (NV) value;
379 }
380 value_nv *= 8.0;
98994639 381 /* If an NV has not enough bits in its mantissa to
d1be9408 382 * represent a UV this summing of small low-order numbers
98994639 383 * is a waste of time (because the NV cannot preserve
384 * the low-order bits anyway): we could just remember when
53305cf1 385 * did we overflow and in the end just multiply value_nv by the
386 * right amount of 8-tuples. */
387 value_nv += (NV)digit;
388 continue;
389 }
390 if (digit == ('_' - '0') && len && allow_underscores
391 && (digit = s[1] - '0') && (digit >= 0 && digit <= 7))
392 {
393 --len;
394 ++s;
395 goto redo;
396 }
397 /* Allow \octal to work the DWIM way (that is, stop scanning
398 * as soon as non-octal characters are seen, complain only iff
399 * someone seems to want to use the digits eight and nine). */
400 if (digit == 8 || digit == 9) {
401 if (ckWARN(WARN_DIGIT))
9014280d 402 Perl_warner(aTHX_ packWARN(WARN_DIGIT),
53305cf1 403 "Illegal octal digit '%c' ignored", *s);
404 }
405 break;
98994639 406 }
53305cf1 407
408 if ( ( overflowed && value_nv > 4294967295.0)
98994639 409#if UVSIZE > 4
53305cf1 410 || (!overflowed && value > 0xffffffff )
98994639 411#endif
412 ) {
413 if (ckWARN(WARN_PORTABLE))
9014280d 414 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
53305cf1 415 "Octal number > 037777777777 non-portable");
416 }
417 *len_p = s - start;
418 if (!overflowed) {
419 *flags = 0;
420 return value;
98994639 421 }
53305cf1 422 *flags = PERL_SCAN_GREATER_THAN_UV_MAX;
423 if (result)
424 *result = value_nv;
425 return UV_MAX;
426}
427
428/*
429=for apidoc scan_bin
430
431For backwards compatibility. Use C<grok_bin> instead.
432
433=for apidoc scan_hex
434
435For backwards compatibility. Use C<grok_hex> instead.
436
437=for apidoc scan_oct
438
439For backwards compatibility. Use C<grok_oct> instead.
440
441=cut
442 */
443
444NV
445Perl_scan_bin(pTHX_ char *start, STRLEN len, STRLEN *retlen)
446{
447 NV rnv;
448 I32 flags = *retlen ? PERL_SCAN_ALLOW_UNDERSCORES : 0;
449 UV ruv = grok_bin (start, &len, &flags, &rnv);
450
451 *retlen = len;
452 return (flags & PERL_SCAN_GREATER_THAN_UV_MAX) ? rnv : (NV)ruv;
453}
454
455NV
456Perl_scan_oct(pTHX_ char *start, STRLEN len, STRLEN *retlen)
457{
458 NV rnv;
459 I32 flags = *retlen ? PERL_SCAN_ALLOW_UNDERSCORES : 0;
460 UV ruv = grok_oct (start, &len, &flags, &rnv);
461
462 *retlen = len;
463 return (flags & PERL_SCAN_GREATER_THAN_UV_MAX) ? rnv : (NV)ruv;
464}
465
466NV
467Perl_scan_hex(pTHX_ char *start, STRLEN len, STRLEN *retlen)
468{
469 NV rnv;
470 I32 flags = *retlen ? PERL_SCAN_ALLOW_UNDERSCORES : 0;
471 UV ruv = grok_hex (start, &len, &flags, &rnv);
472
473 *retlen = len;
474 return (flags & PERL_SCAN_GREATER_THAN_UV_MAX) ? rnv : (NV)ruv;
98994639 475}
476
477/*
478=for apidoc grok_numeric_radix
479
480Scan and skip for a numeric decimal separator (radix).
481
482=cut
483 */
484bool
485Perl_grok_numeric_radix(pTHX_ const char **sp, const char *send)
486{
487#ifdef USE_LOCALE_NUMERIC
488 if (PL_numeric_radix_sv && IN_LOCALE) {
489 STRLEN len;
490 char* radix = SvPV(PL_numeric_radix_sv, len);
491 if (*sp + len <= send && memEQ(*sp, radix, len)) {
492 *sp += len;
493 return TRUE;
494 }
495 }
496 /* always try "." if numeric radix didn't match because
497 * we may have data from different locales mixed */
498#endif
499 if (*sp < send && **sp == '.') {
500 ++*sp;
501 return TRUE;
502 }
503 return FALSE;
504}
505
506/*
507=for apidoc grok_number
508
509Recognise (or not) a number. The type of the number is returned
510(0 if unrecognised), otherwise it is a bit-ORed combination of
511IS_NUMBER_IN_UV, IS_NUMBER_GREATER_THAN_UV_MAX, IS_NUMBER_NOT_INT,
aa8b85de 512IS_NUMBER_NEG, IS_NUMBER_INFINITY, IS_NUMBER_NAN (defined in perl.h).
60939fb8 513
514If the value of the number can fit an in UV, it is returned in the *valuep
515IS_NUMBER_IN_UV will be set to indicate that *valuep is valid, IS_NUMBER_IN_UV
516will never be set unless *valuep is valid, but *valuep may have been assigned
517to during processing even though IS_NUMBER_IN_UV is not set on return.
518If valuep is NULL, IS_NUMBER_IN_UV will be set for the same cases as when
519valuep is non-NULL, but no actual assignment (or SEGV) will occur.
520
521IS_NUMBER_NOT_INT will be set with IS_NUMBER_IN_UV if trailing decimals were
522seen (in which case *valuep gives the true value truncated to an integer), and
523IS_NUMBER_NEG if the number is negative (in which case *valuep holds the
524absolute value). IS_NUMBER_IN_UV is not set if e notation was used or the
525number is larger than a UV.
98994639 526
527=cut
528 */
529int
530Perl_grok_number(pTHX_ const char *pv, STRLEN len, UV *valuep)
531{
60939fb8 532 const char *s = pv;
533 const char *send = pv + len;
534 const UV max_div_10 = UV_MAX / 10;
535 const char max_mod_10 = UV_MAX % 10;
536 int numtype = 0;
537 int sawinf = 0;
aa8b85de 538 int sawnan = 0;
60939fb8 539
540 while (s < send && isSPACE(*s))
541 s++;
542 if (s == send) {
543 return 0;
544 } else if (*s == '-') {
545 s++;
546 numtype = IS_NUMBER_NEG;
547 }
548 else if (*s == '+')
549 s++;
550
551 if (s == send)
552 return 0;
553
554 /* next must be digit or the radix separator or beginning of infinity */
555 if (isDIGIT(*s)) {
556 /* UVs are at least 32 bits, so the first 9 decimal digits cannot
557 overflow. */
558 UV value = *s - '0';
559 /* This construction seems to be more optimiser friendly.
560 (without it gcc does the isDIGIT test and the *s - '0' separately)
561 With it gcc on arm is managing 6 instructions (6 cycles) per digit.
562 In theory the optimiser could deduce how far to unroll the loop
563 before checking for overflow. */
58bb9ec3 564 if (++s < send) {
565 int digit = *s - '0';
60939fb8 566 if (digit >= 0 && digit <= 9) {
567 value = value * 10 + digit;
58bb9ec3 568 if (++s < send) {
569 digit = *s - '0';
60939fb8 570 if (digit >= 0 && digit <= 9) {
571 value = value * 10 + digit;
58bb9ec3 572 if (++s < send) {
573 digit = *s - '0';
60939fb8 574 if (digit >= 0 && digit <= 9) {
575 value = value * 10 + digit;
58bb9ec3 576 if (++s < send) {
577 digit = *s - '0';
60939fb8 578 if (digit >= 0 && digit <= 9) {
579 value = value * 10 + digit;
58bb9ec3 580 if (++s < send) {
581 digit = *s - '0';
60939fb8 582 if (digit >= 0 && digit <= 9) {
583 value = value * 10 + digit;
58bb9ec3 584 if (++s < send) {
585 digit = *s - '0';
60939fb8 586 if (digit >= 0 && digit <= 9) {
587 value = value * 10 + digit;
58bb9ec3 588 if (++s < send) {
589 digit = *s - '0';
60939fb8 590 if (digit >= 0 && digit <= 9) {
591 value = value * 10 + digit;
58bb9ec3 592 if (++s < send) {
593 digit = *s - '0';
60939fb8 594 if (digit >= 0 && digit <= 9) {
595 value = value * 10 + digit;
58bb9ec3 596 if (++s < send) {
60939fb8 597 /* Now got 9 digits, so need to check
598 each time for overflow. */
58bb9ec3 599 digit = *s - '0';
60939fb8 600 while (digit >= 0 && digit <= 9
601 && (value < max_div_10
602 || (value == max_div_10
603 && digit <= max_mod_10))) {
604 value = value * 10 + digit;
58bb9ec3 605 if (++s < send)
606 digit = *s - '0';
60939fb8 607 else
608 break;
609 }
610 if (digit >= 0 && digit <= 9
51bd16da 611 && (s < send)) {
60939fb8 612 /* value overflowed.
613 skip the remaining digits, don't
614 worry about setting *valuep. */
615 do {
616 s++;
617 } while (s < send && isDIGIT(*s));
618 numtype |=
619 IS_NUMBER_GREATER_THAN_UV_MAX;
620 goto skip_value;
621 }
622 }
623 }
98994639 624 }
60939fb8 625 }
626 }
627 }
628 }
629 }
630 }
631 }
632 }
633 }
634 }
635 }
98994639 636 }
60939fb8 637 }
98994639 638 }
60939fb8 639 numtype |= IS_NUMBER_IN_UV;
640 if (valuep)
641 *valuep = value;
642
643 skip_value:
644 if (GROK_NUMERIC_RADIX(&s, send)) {
645 numtype |= IS_NUMBER_NOT_INT;
646 while (s < send && isDIGIT(*s)) /* optional digits after the radix */
647 s++;
98994639 648 }
60939fb8 649 }
650 else if (GROK_NUMERIC_RADIX(&s, send)) {
651 numtype |= IS_NUMBER_NOT_INT | IS_NUMBER_IN_UV; /* valuep assigned below */
652 /* no digits before the radix means we need digits after it */
653 if (s < send && isDIGIT(*s)) {
654 do {
655 s++;
656 } while (s < send && isDIGIT(*s));
657 if (valuep) {
658 /* integer approximation is valid - it's 0. */
659 *valuep = 0;
660 }
98994639 661 }
60939fb8 662 else
663 return 0;
664 } else if (*s == 'I' || *s == 'i') {
665 s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
666 s++; if (s == send || (*s != 'F' && *s != 'f')) return 0;
667 s++; if (s < send && (*s == 'I' || *s == 'i')) {
668 s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
669 s++; if (s == send || (*s != 'I' && *s != 'i')) return 0;
670 s++; if (s == send || (*s != 'T' && *s != 't')) return 0;
671 s++; if (s == send || (*s != 'Y' && *s != 'y')) return 0;
672 s++;
98994639 673 }
60939fb8 674 sawinf = 1;
aa8b85de 675 } else if (*s == 'N' || *s == 'n') {
676 /* XXX TODO: There are signaling NaNs and quiet NaNs. */
677 s++; if (s == send || (*s != 'A' && *s != 'a')) return 0;
678 s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
679 s++;
680 sawnan = 1;
681 } else
98994639 682 return 0;
60939fb8 683
684 if (sawinf) {
685 numtype &= IS_NUMBER_NEG; /* Keep track of sign */
686 numtype |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT;
aa8b85de 687 } else if (sawnan) {
688 numtype &= IS_NUMBER_NEG; /* Keep track of sign */
689 numtype |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT;
60939fb8 690 } else if (s < send) {
691 /* we can have an optional exponent part */
692 if (*s == 'e' || *s == 'E') {
693 /* The only flag we keep is sign. Blow away any "it's UV" */
694 numtype &= IS_NUMBER_NEG;
695 numtype |= IS_NUMBER_NOT_INT;
696 s++;
697 if (s < send && (*s == '-' || *s == '+'))
698 s++;
699 if (s < send && isDIGIT(*s)) {
700 do {
701 s++;
702 } while (s < send && isDIGIT(*s));
703 }
704 else
705 return 0;
706 }
707 }
708 while (s < send && isSPACE(*s))
709 s++;
710 if (s >= send)
aa8b85de 711 return numtype;
60939fb8 712 if (len == 10 && memEQ(pv, "0 but true", 10)) {
713 if (valuep)
714 *valuep = 0;
715 return IS_NUMBER_IN_UV;
716 }
717 return 0;
98994639 718}
719
720NV
721S_mulexp10(NV value, I32 exponent)
722{
723 NV result = 1.0;
724 NV power = 10.0;
725 bool negative = 0;
726 I32 bit;
727
728 if (exponent == 0)
729 return value;
730 else if (exponent < 0) {
731 negative = 1;
732 exponent = -exponent;
733 }
87032ba1 734
24866caa 735 /* On OpenVMS VAX we by default use the D_FLOAT double format,
67597c89 736 * and that format does not have *easy* capabilities [1] for
24866caa 737 * overflowing doubles 'silently' as IEEE fp does. We also need
738 * to support G_FLOAT on both VAX and Alpha, and though the exponent
739 * range is much larger than D_FLOAT it still doesn't do silent
740 * overflow. Therefore we need to detect early whether we would
741 * overflow (this is the behaviour of the native string-to-float
742 * conversion routines, and therefore of native applications, too).
67597c89 743 *
24866caa 744 * [1] Trying to establish a condition handler to trap floating point
745 * exceptions is not a good idea. */
746#if defined(VMS) && !defined(__IEEE_FP) && defined(NV_MAX_10_EXP)
67597c89 747 if (!negative &&
24866caa 748 (log10(value) + exponent) >= (NV_MAX_10_EXP))
67597c89 749 return NV_MAX;
67597c89 750#endif
87032ba1 751
752 /* In UNICOS and in certain Cray models (such as T90) there is no
753 * IEEE fp, and no way at all from C to catch fp overflows gracefully.
754 * There is something you can do if you are willing to use some
755 * inline assembler: the instruction is called DFI-- but that will
756 * disable *all* floating point interrupts, a little bit too large
757 * a hammer. Therefore we need to catch potential overflows before
758 * it's too late. */
759#if defined(_UNICOS) && defined(NV_MAX_10_EXP)
760 if (!negative &&
761 (log10(value) + exponent) >= NV_MAX_10_EXP)
762 return NV_MAX;
763#endif
764
98994639 765 for (bit = 1; exponent; bit <<= 1) {
766 if (exponent & bit) {
767 exponent ^= bit;
768 result *= power;
769 }
7014c407 770 /* Floating point exceptions are supposed to be turned off. */
98994639 771 power *= power;
772 }
773 return negative ? value / result : value * result;
774}
775
776NV
777Perl_my_atof(pTHX_ const char* s)
778{
779 NV x = 0.0;
780#ifdef USE_LOCALE_NUMERIC
781 if (PL_numeric_local && IN_LOCALE) {
782 NV y;
783
784 /* Scan the number twice; once using locale and once without;
785 * choose the larger result (in absolute value). */
786 Perl_atof2(aTHX_ s, &x);
787 SET_NUMERIC_STANDARD();
788 Perl_atof2(aTHX_ s, &y);
789 SET_NUMERIC_LOCAL();
790 if ((y < 0.0 && y < x) || (y > 0.0 && y > x))
791 return y;
792 }
793 else
794 Perl_atof2(aTHX_ s, &x);
795#else
796 Perl_atof2(aTHX_ s, &x);
797#endif
798 return x;
799}
800
801char*
802Perl_my_atof2(pTHX_ const char* orig, NV* value)
803{
804 NV result = 0.0;
805 bool negative = 0;
806 char* s = (char*)orig;
807 char* send = s + strlen(orig) - 1;
808 bool seendigit = 0;
809 I32 expextra = 0;
810 I32 exponent = 0;
811 I32 i;
812/* this is arbitrary */
813#define PARTLIM 6
814/* we want the largest integers we can usefully use */
815#if defined(HAS_QUAD) && defined(USE_64_BIT_INT)
816# define PARTSIZE ((int)TYPE_DIGITS(U64)-1)
817 U64 part[PARTLIM];
818#else
819# define PARTSIZE ((int)TYPE_DIGITS(U32)-1)
820 U32 part[PARTLIM];
821#endif
822 I32 ipart = 0; /* index into part[] */
823 I32 offcount; /* number of digits in least significant part */
824
96a05aee 825 /* leading whitespace */
826 while (isSPACE(*s))
827 ++s;
828
98994639 829 /* sign */
830 switch (*s) {
831 case '-':
832 negative = 1;
833 /* fall through */
834 case '+':
835 ++s;
836 }
837
838 part[0] = offcount = 0;
839 if (isDIGIT(*s)) {
840 seendigit = 1; /* get this over with */
841
842 /* skip leading zeros */
843 while (*s == '0')
844 ++s;
845 }
846
847 /* integer digits */
848 while (isDIGIT(*s)) {
849 if (++offcount > PARTSIZE) {
850 if (++ipart < PARTLIM) {
851 part[ipart] = 0;
852 offcount = 1; /* ++0 */
853 }
854 else {
855 /* limits of precision reached */
856 --ipart;
857 --offcount;
858 if (*s >= '5')
859 ++part[ipart];
860 while (isDIGIT(*s)) {
861 ++expextra;
862 ++s;
863 }
864 /* warn of loss of precision? */
865 break;
866 }
867 }
868 part[ipart] = part[ipart] * 10 + (*s++ - '0');
869 }
870
871 /* decimal point */
872 if (GROK_NUMERIC_RADIX((const char **)&s, send)) {
873 if (isDIGIT(*s))
874 seendigit = 1; /* get this over with */
875
876 /* decimal digits */
877 while (isDIGIT(*s)) {
878 if (++offcount > PARTSIZE) {
879 if (++ipart < PARTLIM) {
880 part[ipart] = 0;
881 offcount = 1; /* ++0 */
882 }
883 else {
884 /* limits of precision reached */
885 --ipart;
886 --offcount;
887 if (*s >= '5')
888 ++part[ipart];
889 while (isDIGIT(*s))
890 ++s;
891 /* warn of loss of precision? */
892 break;
893 }
894 }
895 --expextra;
896 part[ipart] = part[ipart] * 10 + (*s++ - '0');
897 }
898 }
899
900 /* combine components of mantissa */
901 for (i = 0; i <= ipart; ++i)
902 result += S_mulexp10((NV)part[ipart - i],
903 i ? offcount + (i - 1) * PARTSIZE : 0);
904
905 if (seendigit && (*s == 'e' || *s == 'E')) {
906 bool expnegative = 0;
907
908 ++s;
909 switch (*s) {
910 case '-':
911 expnegative = 1;
912 /* fall through */
913 case '+':
914 ++s;
915 }
916 while (isDIGIT(*s))
917 exponent = exponent * 10 + (*s++ - '0');
918 if (expnegative)
919 exponent = -exponent;
920 }
921
922 /* now apply the exponent */
923 exponent += expextra;
924 result = S_mulexp10(result, exponent);
925
926 /* now apply the sign */
927 if (negative)
928 result = -result;
929 *value = result;
930 return s;
931}
932