This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Re: [perl #16198] pod tpyo in hostent.pm
[perl5.git] / numeric.c
CommitLineData
98994639
HS
1/* numeric.c
2 *
be3c0a43 3 * Copyright (c) 2001-2002, Larry Wall
98994639
HS
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
JH
15/*
16=head1 Numeric functions
17*/
18
98994639
HS
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
NC
112/*
113=for apidoc grok_bin
98994639 114
53305cf1
NC
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
NC
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
NC
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
NC
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
NC
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
NC
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
HS
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
NC
190 value_nv += (NV)(bit - '0');
191 continue;
192 }
193 if (bit == '_' && len && allow_underscores && (bit = s[1])
194 && (bit == '0' || bit == '1'))
98994639
HS
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
NC
202 "Illegal binary digit '%c' ignored", *s);
203 break;
98994639 204 }
53305cf1
NC
205
206 if ( ( overflowed && value_nv > 4294967295.0)
98994639 207#if UVSIZE > 4
53305cf1 208 || (!overflowed && value > 0xffffffff )
98994639
HS
209#endif
210 ) {
211 if (ckWARN(WARN_PORTABLE))
9014280d 212 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
53305cf1
NC
213 "Binary number > 0b11111111111111111111111111111111 non-portable");
214 }
215 *len_p = s - start;
216 if (!overflowed) {
217 *flags = 0;
218 return value;
98994639 219 }
53305cf1
NC
220 *flags = PERL_SCAN_GREATER_THAN_UV_MAX;
221 if (result)
222 *result = value_nv;
223 return UV_MAX;
98994639
HS
224}
225
53305cf1
NC
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
NC
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
NC
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
NC
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
HS
277 }
278
279 for (; len-- && *s; s++) {
280 hexdigit = strchr((char *) PL_hexdigit, *s);
53305cf1
NC
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
NC
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
NC
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
HS
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
NC
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
NC
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
NC
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
HS
383 * is a waste of time (because the NV cannot preserve
384 * the low-order bits anyway): we could just remember when
53305cf1
NC
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
NC
403 "Illegal octal digit '%c' ignored", *s);
404 }
405 break;
98994639 406 }
53305cf1
NC
407
408 if ( ( overflowed && value_nv > 4294967295.0)
98994639 409#if UVSIZE > 4
53305cf1 410 || (!overflowed && value > 0xffffffff )
98994639
HS
411#endif
412 ) {
413 if (ckWARN(WARN_PORTABLE))
9014280d 414 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
53305cf1
NC
415 "Octal number > 037777777777 non-portable");
416 }
417 *len_p = s - start;
418 if (!overflowed) {
419 *flags = 0;
420 return value;
98994639 421 }
53305cf1
NC
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
HS
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
NC
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
HS
526
527=cut
528 */
529int
530Perl_grok_number(pTHX_ const char *pv, STRLEN len, UV *valuep)
531{
60939fb8
NC
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
NC
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
NC
564 if (++s < send) {
565 int digit = *s - '0';
60939fb8
NC
566 if (digit >= 0 && digit <= 9) {
567 value = value * 10 + digit;
58bb9ec3
NC
568 if (++s < send) {
569 digit = *s - '0';
60939fb8
NC
570 if (digit >= 0 && digit <= 9) {
571 value = value * 10 + digit;
58bb9ec3
NC
572 if (++s < send) {
573 digit = *s - '0';
60939fb8
NC
574 if (digit >= 0 && digit <= 9) {
575 value = value * 10 + digit;
58bb9ec3
NC
576 if (++s < send) {
577 digit = *s - '0';
60939fb8
NC
578 if (digit >= 0 && digit <= 9) {
579 value = value * 10 + digit;
58bb9ec3
NC
580 if (++s < send) {
581 digit = *s - '0';
60939fb8
NC
582 if (digit >= 0 && digit <= 9) {
583 value = value * 10 + digit;
58bb9ec3
NC
584 if (++s < send) {
585 digit = *s - '0';
60939fb8
NC
586 if (digit >= 0 && digit <= 9) {
587 value = value * 10 + digit;
58bb9ec3
NC
588 if (++s < send) {
589 digit = *s - '0';
60939fb8
NC
590 if (digit >= 0 && digit <= 9) {
591 value = value * 10 + digit;
58bb9ec3
NC
592 if (++s < send) {
593 digit = *s - '0';
60939fb8
NC
594 if (digit >= 0 && digit <= 9) {
595 value = value * 10 + digit;
58bb9ec3 596 if (++s < send) {
60939fb8
NC
597 /* Now got 9 digits, so need to check
598 each time for overflow. */
58bb9ec3 599 digit = *s - '0';
60939fb8
NC
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
NC
605 if (++s < send)
606 digit = *s - '0';
60939fb8
NC
607 else
608 break;
609 }
610 if (digit >= 0 && digit <= 9
51bd16da 611 && (s < send)) {
60939fb8
NC
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
NC
625 }
626 }
627 }
628 }
629 }
630 }
631 }
632 }
633 }
634 }
635 }
98994639 636 }
60939fb8 637 }
98994639 638 }
60939fb8
NC
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
NC
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
NC
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
JH
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
NC
683
684 if (sawinf) {
685 numtype &= IS_NUMBER_NEG; /* Keep track of sign */
686 numtype |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT;
aa8b85de
JH
687 } else if (sawnan) {
688 numtype &= IS_NUMBER_NEG; /* Keep track of sign */
689 numtype |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT;
60939fb8
NC
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
NC
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
HS
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;
87032ba1 730
24866caa 731 /* On OpenVMS VAX we by default use the D_FLOAT double format,
67597c89 732 * and that format does not have *easy* capabilities [1] for
24866caa
CB
733 * overflowing doubles 'silently' as IEEE fp does. We also need
734 * to support G_FLOAT on both VAX and Alpha, and though the exponent
735 * range is much larger than D_FLOAT it still doesn't do silent
736 * overflow. Therefore we need to detect early whether we would
737 * overflow (this is the behaviour of the native string-to-float
738 * conversion routines, and therefore of native applications, too).
67597c89 739 *
24866caa
CB
740 * [1] Trying to establish a condition handler to trap floating point
741 * exceptions is not a good idea. */
87032ba1
JH
742
743 /* In UNICOS and in certain Cray models (such as T90) there is no
744 * IEEE fp, and no way at all from C to catch fp overflows gracefully.
745 * There is something you can do if you are willing to use some
746 * inline assembler: the instruction is called DFI-- but that will
747 * disable *all* floating point interrupts, a little bit too large
748 * a hammer. Therefore we need to catch potential overflows before
749 * it's too late. */
353813d9
HS
750
751#if ((defined(VMS) && !defined(__IEEE_FP)) || defined(_UNICOS)) && defined(NV_MAX_10_EXP)
752 STMT_START {
753 NV exp_v = log10(value);
754 if (exponent >= NV_MAX_10_EXP || exponent + exp_v >= NV_MAX_10_EXP)
755 return NV_MAX;
756 if (exponent < 0) {
757 if (-(exponent + exp_v) >= NV_MAX_10_EXP)
758 return 0.0;
759 while (-exponent >= NV_MAX_10_EXP) {
760 /* combination does not overflow, but 10^(-exponent) does */
761 value /= 10;
762 ++exponent;
763 }
764 }
765 } STMT_END;
87032ba1
JH
766#endif
767
353813d9
HS
768 if (exponent < 0) {
769 negative = 1;
770 exponent = -exponent;
771 }
98994639
HS
772 for (bit = 1; exponent; bit <<= 1) {
773 if (exponent & bit) {
774 exponent ^= bit;
775 result *= power;
236f0012
CB
776 /* Floating point exceptions are supposed to be turned off,
777 * but if we're obviously done, don't risk another iteration.
778 */
779 if (exponent == 0) break;
98994639
HS
780 }
781 power *= power;
782 }
783 return negative ? value / result : value * result;
784}
785
786NV
787Perl_my_atof(pTHX_ const char* s)
788{
789 NV x = 0.0;
790#ifdef USE_LOCALE_NUMERIC
791 if (PL_numeric_local && IN_LOCALE) {
792 NV y;
793
794 /* Scan the number twice; once using locale and once without;
795 * choose the larger result (in absolute value). */
a36244b7 796 Perl_atof2(s, x);
98994639 797 SET_NUMERIC_STANDARD();
a36244b7 798 Perl_atof2(s, y);
98994639
HS
799 SET_NUMERIC_LOCAL();
800 if ((y < 0.0 && y < x) || (y > 0.0 && y > x))
801 return y;
802 }
803 else
a36244b7 804 Perl_atof2(s, x);
98994639 805#else
a36244b7 806 Perl_atof2(s, x);
98994639
HS
807#endif
808 return x;
809}
810
811char*
812Perl_my_atof2(pTHX_ const char* orig, NV* value)
813{
814 NV result = 0.0;
98994639 815 char* s = (char*)orig;
a36244b7
JH
816#ifdef USE_PERL_ATOF
817 bool negative = 0;
98994639
HS
818 char* send = s + strlen(orig) - 1;
819 bool seendigit = 0;
820 I32 expextra = 0;
821 I32 exponent = 0;
822 I32 i;
823/* this is arbitrary */
824#define PARTLIM 6
825/* we want the largest integers we can usefully use */
826#if defined(HAS_QUAD) && defined(USE_64_BIT_INT)
827# define PARTSIZE ((int)TYPE_DIGITS(U64)-1)
828 U64 part[PARTLIM];
829#else
830# define PARTSIZE ((int)TYPE_DIGITS(U32)-1)
831 U32 part[PARTLIM];
832#endif
833 I32 ipart = 0; /* index into part[] */
834 I32 offcount; /* number of digits in least significant part */
835
96a05aee
HS
836 /* leading whitespace */
837 while (isSPACE(*s))
838 ++s;
839
98994639
HS
840 /* sign */
841 switch (*s) {
842 case '-':
843 negative = 1;
844 /* fall through */
845 case '+':
846 ++s;
847 }
848
849 part[0] = offcount = 0;
850 if (isDIGIT(*s)) {
851 seendigit = 1; /* get this over with */
852
853 /* skip leading zeros */
854 while (*s == '0')
855 ++s;
856 }
857
858 /* integer digits */
859 while (isDIGIT(*s)) {
860 if (++offcount > PARTSIZE) {
861 if (++ipart < PARTLIM) {
862 part[ipart] = 0;
863 offcount = 1; /* ++0 */
864 }
865 else {
866 /* limits of precision reached */
867 --ipart;
868 --offcount;
869 if (*s >= '5')
870 ++part[ipart];
871 while (isDIGIT(*s)) {
872 ++expextra;
873 ++s;
874 }
875 /* warn of loss of precision? */
876 break;
877 }
878 }
879 part[ipart] = part[ipart] * 10 + (*s++ - '0');
880 }
881
882 /* decimal point */
883 if (GROK_NUMERIC_RADIX((const char **)&s, send)) {
884 if (isDIGIT(*s))
885 seendigit = 1; /* get this over with */
886
887 /* decimal digits */
888 while (isDIGIT(*s)) {
889 if (++offcount > PARTSIZE) {
890 if (++ipart < PARTLIM) {
891 part[ipart] = 0;
892 offcount = 1; /* ++0 */
893 }
894 else {
895 /* limits of precision reached */
896 --ipart;
897 --offcount;
898 if (*s >= '5')
899 ++part[ipart];
900 while (isDIGIT(*s))
901 ++s;
902 /* warn of loss of precision? */
903 break;
904 }
905 }
906 --expextra;
907 part[ipart] = part[ipart] * 10 + (*s++ - '0');
908 }
909 }
910
911 /* combine components of mantissa */
912 for (i = 0; i <= ipart; ++i)
913 result += S_mulexp10((NV)part[ipart - i],
914 i ? offcount + (i - 1) * PARTSIZE : 0);
915
916 if (seendigit && (*s == 'e' || *s == 'E')) {
917 bool expnegative = 0;
918
919 ++s;
920 switch (*s) {
921 case '-':
922 expnegative = 1;
923 /* fall through */
924 case '+':
925 ++s;
926 }
927 while (isDIGIT(*s))
928 exponent = exponent * 10 + (*s++ - '0');
929 if (expnegative)
930 exponent = -exponent;
931 }
932
933 /* now apply the exponent */
934 exponent += expextra;
935 result = S_mulexp10(result, exponent);
936
937 /* now apply the sign */
938 if (negative)
939 result = -result;
a36244b7 940#endif /* USE_PERL_ATOF */
98994639
HS
941 *value = result;
942 return s;
943}
944