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