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