This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
numeric.c: Fix typo in pod
[perl5.git] / numeric.c
CommitLineData
98994639
HS
1/* numeric.c
2 *
663f364b 3 * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,
1129b882 4 * 2002, 2003, 2004, 2005, 2006, 2007, 2008 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/*
4ac71550
TC
12 * "That only makes eleven (plus one mislaid) and not fourteen,
13 * unless wizards count differently to other people." --Beorn
14 *
15 * [p.115 of _The Hobbit_: "Queer Lodgings"]
98994639
HS
16 */
17
ccfc67b7
JH
18/*
19=head1 Numeric functions
166f8a29 20
7fefc6c1
KW
21=cut
22
166f8a29
DM
23This file contains all the stuff needed by perl for manipulating numeric
24values, including such things as replacements for the OS's atof() function
25
ccfc67b7
JH
26*/
27
98994639
HS
28#include "EXTERN.h"
29#define PERL_IN_NUMERIC_C
30#include "perl.h"
31
9ec8aea5
KW
32#ifdef Perl_strtod
33
34PERL_STATIC_INLINE NV
35S_strtod(pTHX_ const char * const s, char ** e)
36{
37 DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
38 NV result;
39
40 STORE_LC_NUMERIC_SET_TO_NEEDED();
41
42# ifdef USE_QUADMATH
43
44 result = strtoflt128(s, e);
45
46# elif defined(HAS_STRTOLD) && defined(HAS_LONG_DOUBLE) \
47 && defined(USE_LONG_DOUBLE)
48# if defined(__MINGW64_VERSION_MAJOR)
49 /***********************************************
50 We are unable to use strtold because of
51 https://sourceforge.net/p/mingw-w64/bugs/711/
52 &
53 https://sourceforge.net/p/mingw-w64/bugs/725/
54
55 but __mingw_strtold is fine.
56 ***********************************************/
57
58 result = __mingw_strtold(s, e);
59
60# else
61
62 result = strtold(s, e);
63
64# endif
65# elif defined(HAS_STRTOD)
66
67 result = strtod(s, e);
68
02fd9d54
KW
69# else
70# error No strtod() equivalent found
9ec8aea5
KW
71# endif
72
73 RESTORE_LC_NUMERIC();
74
75 return result;
76}
77
78#endif /* #ifdef Perl_strtod */
79
80/*
81
82=for apidoc my_strtod
83
84This function is equivalent to the libc strtod() function, and is available
85even on platforms that lack plain strtod(). Its return value is the best
86available precision depending on platform capabilities and F<Configure>
87options.
88
89It properly handles the locale radix character, meaning it expects a dot except
90when called from within the scope of S<C<use locale>>, in which case the radix
91character should be that specified by the current locale.
92
e7a3fd45 93The synonym Strtod() may be used instead.
9ec8aea5
KW
94
95=cut
96
97*/
98
99NV
0f3d8cd4 100Perl_my_strtod(const char * const s, char **e)
9ec8aea5
KW
101{
102 dTHX;
103
104 PERL_ARGS_ASSERT_MY_STRTOD;
105
106#ifdef Perl_strtod
107
108 return S_strtod(aTHX_ s, e);
109
110#else
111
112 {
113 NV result;
114 char ** end_ptr = NULL;
115
116 *end_ptr = my_atof2(s, &result);
117 if (e) {
118 *e = *end_ptr;
119 }
120
121 if (! *end_ptr) {
122 result = 0.0;
123 }
124
125 return result;
126 }
127
128#endif
129
130}
131
132
98994639 133U32
ddeaf645 134Perl_cast_ulong(NV f)
98994639
HS
135{
136 if (f < 0.0)
137 return f < I32_MIN ? (U32) I32_MIN : (U32)(I32) f;
138 if (f < U32_MAX_P1) {
139#if CASTFLAGS & 2
140 if (f < U32_MAX_P1_HALF)
141 return (U32) f;
142 f -= U32_MAX_P1_HALF;
071db91b 143 return ((U32) f) | (1 + (U32_MAX >> 1));
98994639
HS
144#else
145 return (U32) f;
146#endif
147 }
148 return f > 0 ? U32_MAX : 0 /* NaN */;
149}
150
151I32
ddeaf645 152Perl_cast_i32(NV f)
98994639
HS
153{
154 if (f < I32_MAX_P1)
155 return f < I32_MIN ? I32_MIN : (I32) f;
156 if (f < U32_MAX_P1) {
157#if CASTFLAGS & 2
158 if (f < U32_MAX_P1_HALF)
159 return (I32)(U32) f;
160 f -= U32_MAX_P1_HALF;
071db91b 161 return (I32)(((U32) f) | (1 + (U32_MAX >> 1)));
98994639
HS
162#else
163 return (I32)(U32) f;
164#endif
165 }
166 return f > 0 ? (I32)U32_MAX : 0 /* NaN */;
167}
168
169IV
ddeaf645 170Perl_cast_iv(NV f)
98994639
HS
171{
172 if (f < IV_MAX_P1)
173 return f < IV_MIN ? IV_MIN : (IV) f;
174 if (f < UV_MAX_P1) {
175#if CASTFLAGS & 2
176 /* For future flexibility allowing for sizeof(UV) >= sizeof(IV) */
177 if (f < UV_MAX_P1_HALF)
178 return (IV)(UV) f;
179 f -= UV_MAX_P1_HALF;
071db91b 180 return (IV)(((UV) f) | (1 + (UV_MAX >> 1)));
98994639
HS
181#else
182 return (IV)(UV) f;
183#endif
184 }
185 return f > 0 ? (IV)UV_MAX : 0 /* NaN */;
186}
187
188UV
ddeaf645 189Perl_cast_uv(NV f)
98994639
HS
190{
191 if (f < 0.0)
192 return f < IV_MIN ? (UV) IV_MIN : (UV)(IV) f;
193 if (f < UV_MAX_P1) {
194#if CASTFLAGS & 2
195 if (f < UV_MAX_P1_HALF)
196 return (UV) f;
197 f -= UV_MAX_P1_HALF;
071db91b 198 return ((UV) f) | (1 + (UV_MAX >> 1));
98994639
HS
199#else
200 return (UV) f;
201#endif
202 }
203 return f > 0 ? UV_MAX : 0 /* NaN */;
204}
205
53305cf1
NC
206/*
207=for apidoc grok_bin
98994639 208
53305cf1
NC
209converts a string representing a binary number to numeric form.
210
2d7f6611 211On entry C<start> and C<*len> give the string to scan, C<*flags> gives
796b6530 212conversion flags, and C<result> should be C<NULL> or a pointer to an NV.
53305cf1 213The scan stops at the end of the string, or the first invalid character.
2d7f6611 214Unless C<PERL_SCAN_SILENT_ILLDIGIT> is set in C<*flags>, encountering an
7b667b5f 215invalid character will also trigger a warning.
2d7f6611
KW
216On return C<*len> is set to the length of the scanned string,
217and C<*flags> gives output flags.
53305cf1 218
7fc63493 219If the value is <= C<UV_MAX> it is returned as a UV, the output flags are clear,
796b6530
KW
220and nothing is written to C<*result>. If the value is > C<UV_MAX>, C<grok_bin>
221returns C<UV_MAX>, sets C<PERL_SCAN_GREATER_THAN_UV_MAX> in the output flags,
2d7f6611 222and writes the value to C<*result> (or the value is discarded if C<result>
53305cf1
NC
223is NULL).
224
796b6530 225The binary number may optionally be prefixed with C<"0b"> or C<"b"> unless
2d7f6611
KW
226C<PERL_SCAN_DISALLOW_PREFIX> is set in C<*flags> on entry. If
227C<PERL_SCAN_ALLOW_UNDERSCORES> is set in C<*flags> then the binary
796b6530 228number may use C<"_"> characters to separate digits.
53305cf1
NC
229
230=cut
02470786
KW
231
232Not documented yet because experimental is C<PERL_SCAN_SILENT_NON_PORTABLE
233which suppresses any message for non-portable numbers that are still valid
234on this platform.
53305cf1
NC
235 */
236
237UV
7918f24d
NC
238Perl_grok_bin(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result)
239{
53305cf1
NC
240 const char *s = start;
241 STRLEN len = *len_p;
242 UV value = 0;
243 NV value_nv = 0;
244
245 const UV max_div_2 = UV_MAX / 2;
f2338a2e 246 const bool allow_underscores = cBOOL(*flags & PERL_SCAN_ALLOW_UNDERSCORES);
53305cf1 247 bool overflowed = FALSE;
7fc63493 248 char bit;
53305cf1 249
7918f24d
NC
250 PERL_ARGS_ASSERT_GROK_BIN;
251
a4c04bdc
NC
252 if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) {
253 /* strip off leading b or 0b.
254 for compatibility silently suffer "b" and "0b" as valid binary
255 numbers. */
256 if (len >= 1) {
305b8651 257 if (isALPHA_FOLD_EQ(s[0], 'b')) {
a4c04bdc
NC
258 s++;
259 len--;
260 }
305b8651 261 else if (len >= 2 && s[0] == '0' && (isALPHA_FOLD_EQ(s[1], 'b'))) {
a4c04bdc
NC
262 s+=2;
263 len-=2;
264 }
265 }
53305cf1
NC
266 }
267
7fc63493 268 for (; len-- && (bit = *s); s++) {
53305cf1
NC
269 if (bit == '0' || bit == '1') {
270 /* Write it in this wonky order with a goto to attempt to get the
271 compiler to make the common case integer-only loop pretty tight.
272 With gcc seems to be much straighter code than old scan_bin. */
273 redo:
274 if (!overflowed) {
275 if (value <= max_div_2) {
276 value = (value << 1) | (bit - '0');
277 continue;
278 }
279 /* Bah. We're just overflowed. */
dcbac5bb 280 /* diag_listed_as: Integer overflow in %s number */
9b387841
NC
281 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
282 "Integer overflow in binary number");
53305cf1
NC
283 overflowed = TRUE;
284 value_nv = (NV) value;
285 }
286 value_nv *= 2.0;
98994639 287 /* If an NV has not enough bits in its mantissa to
d1be9408 288 * represent a UV this summing of small low-order numbers
98994639
HS
289 * is a waste of time (because the NV cannot preserve
290 * the low-order bits anyway): we could just remember when
53305cf1 291 * did we overflow and in the end just multiply value_nv by the
98994639 292 * right amount. */
53305cf1
NC
293 value_nv += (NV)(bit - '0');
294 continue;
295 }
296 if (bit == '_' && len && allow_underscores && (bit = s[1])
297 && (bit == '0' || bit == '1'))
98994639
HS
298 {
299 --len;
300 ++s;
53305cf1 301 goto redo;
98994639 302 }
a2a5de95
NC
303 if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT))
304 Perl_ck_warner(aTHX_ packWARN(WARN_DIGIT),
305 "Illegal binary digit '%c' ignored", *s);
53305cf1 306 break;
98994639 307 }
19c1206d 308
53305cf1 309 if ( ( overflowed && value_nv > 4294967295.0)
98994639 310#if UVSIZE > 4
02470786
KW
311 || (!overflowed && value > 0xffffffff
312 && ! (*flags & PERL_SCAN_SILENT_NON_PORTABLE))
98994639
HS
313#endif
314 ) {
a2a5de95
NC
315 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
316 "Binary number > 0b11111111111111111111111111111111 non-portable");
53305cf1
NC
317 }
318 *len_p = s - start;
319 if (!overflowed) {
320 *flags = 0;
321 return value;
98994639 322 }
53305cf1
NC
323 *flags = PERL_SCAN_GREATER_THAN_UV_MAX;
324 if (result)
325 *result = value_nv;
326 return UV_MAX;
98994639
HS
327}
328
53305cf1
NC
329/*
330=for apidoc grok_hex
331
332converts a string representing a hex number to numeric form.
333
2d7f6611 334On entry C<start> and C<*len_p> give the string to scan, C<*flags> gives
796b6530 335conversion flags, and C<result> should be C<NULL> or a pointer to an NV.
7b667b5f 336The scan stops at the end of the string, or the first invalid character.
2d7f6611 337Unless C<PERL_SCAN_SILENT_ILLDIGIT> is set in C<*flags>, encountering an
7b667b5f 338invalid character will also trigger a warning.
2d7f6611
KW
339On return C<*len> is set to the length of the scanned string,
340and C<*flags> gives output flags.
53305cf1 341
796b6530
KW
342If the value is <= C<UV_MAX> it is returned as a UV, the output flags are clear,
343and nothing is written to C<*result>. If the value is > C<UV_MAX>, C<grok_hex>
344returns C<UV_MAX>, sets C<PERL_SCAN_GREATER_THAN_UV_MAX> in the output flags,
2d7f6611 345and writes the value to C<*result> (or the value is discarded if C<result>
796b6530 346is C<NULL>).
53305cf1 347
796b6530 348The hex number may optionally be prefixed with C<"0x"> or C<"x"> unless
2d7f6611
KW
349C<PERL_SCAN_DISALLOW_PREFIX> is set in C<*flags> on entry. If
350C<PERL_SCAN_ALLOW_UNDERSCORES> is set in C<*flags> then the hex
796b6530 351number may use C<"_"> characters to separate digits.
53305cf1
NC
352
353=cut
02470786
KW
354
355Not documented yet because experimental is C<PERL_SCAN_SILENT_NON_PORTABLE
baf48926 356which suppresses any message for non-portable numbers, but which are valid
02470786 357on this platform.
53305cf1
NC
358 */
359
360UV
7918f24d
NC
361Perl_grok_hex(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result)
362{
53305cf1
NC
363 const char *s = start;
364 STRLEN len = *len_p;
365 UV value = 0;
366 NV value_nv = 0;
53305cf1 367 const UV max_div_16 = UV_MAX / 16;
f2338a2e 368 const bool allow_underscores = cBOOL(*flags & PERL_SCAN_ALLOW_UNDERSCORES);
53305cf1 369 bool overflowed = FALSE;
98994639 370
7918f24d
NC
371 PERL_ARGS_ASSERT_GROK_HEX;
372
a4c04bdc
NC
373 if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) {
374 /* strip off leading x or 0x.
375 for compatibility silently suffer "x" and "0x" as valid hex numbers.
376 */
377 if (len >= 1) {
305b8651 378 if (isALPHA_FOLD_EQ(s[0], 'x')) {
a4c04bdc
NC
379 s++;
380 len--;
381 }
305b8651 382 else if (len >= 2 && s[0] == '0' && (isALPHA_FOLD_EQ(s[1], 'x'))) {
a4c04bdc
NC
383 s+=2;
384 len-=2;
385 }
386 }
98994639
HS
387 }
388
389 for (; len-- && *s; s++) {
626ef089 390 if (isXDIGIT(*s)) {
53305cf1
NC
391 /* Write it in this wonky order with a goto to attempt to get the
392 compiler to make the common case integer-only loop pretty tight.
393 With gcc seems to be much straighter code than old scan_hex. */
394 redo:
395 if (!overflowed) {
396 if (value <= max_div_16) {
626ef089 397 value = (value << 4) | XDIGIT_VALUE(*s);
53305cf1
NC
398 continue;
399 }
400 /* Bah. We're just overflowed. */
dcbac5bb 401 /* diag_listed_as: Integer overflow in %s number */
9b387841
NC
402 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
403 "Integer overflow in hexadecimal number");
53305cf1
NC
404 overflowed = TRUE;
405 value_nv = (NV) value;
406 }
407 value_nv *= 16.0;
408 /* If an NV has not enough bits in its mantissa to
d1be9408 409 * represent a UV this summing of small low-order numbers
53305cf1
NC
410 * is a waste of time (because the NV cannot preserve
411 * the low-order bits anyway): we could just remember when
412 * did we overflow and in the end just multiply value_nv by the
413 * right amount of 16-tuples. */
626ef089 414 value_nv += (NV) XDIGIT_VALUE(*s);
53305cf1
NC
415 continue;
416 }
417 if (*s == '_' && len && allow_underscores && s[1]
626ef089 418 && isXDIGIT(s[1]))
98994639
HS
419 {
420 --len;
421 ++s;
53305cf1 422 goto redo;
98994639 423 }
a2a5de95
NC
424 if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT))
425 Perl_ck_warner(aTHX_ packWARN(WARN_DIGIT),
53305cf1
NC
426 "Illegal hexadecimal digit '%c' ignored", *s);
427 break;
428 }
19c1206d 429
53305cf1
NC
430 if ( ( overflowed && value_nv > 4294967295.0)
431#if UVSIZE > 4
02470786
KW
432 || (!overflowed && value > 0xffffffff
433 && ! (*flags & PERL_SCAN_SILENT_NON_PORTABLE))
53305cf1
NC
434#endif
435 ) {
a2a5de95
NC
436 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
437 "Hexadecimal number > 0xffffffff non-portable");
53305cf1
NC
438 }
439 *len_p = s - start;
440 if (!overflowed) {
441 *flags = 0;
442 return value;
443 }
444 *flags = PERL_SCAN_GREATER_THAN_UV_MAX;
445 if (result)
446 *result = value_nv;
447 return UV_MAX;
448}
449
450/*
451=for apidoc grok_oct
452
7b667b5f
MHM
453converts a string representing an octal number to numeric form.
454
2d7f6611 455On entry C<start> and C<*len> give the string to scan, C<*flags> gives
796b6530 456conversion flags, and C<result> should be C<NULL> or a pointer to an NV.
7b667b5f 457The scan stops at the end of the string, or the first invalid character.
2d7f6611 458Unless C<PERL_SCAN_SILENT_ILLDIGIT> is set in C<*flags>, encountering an
154bd527 4598 or 9 will also trigger a warning.
2d7f6611
KW
460On return C<*len> is set to the length of the scanned string,
461and C<*flags> gives output flags.
7b667b5f 462
796b6530
KW
463If the value is <= C<UV_MAX> it is returned as a UV, the output flags are clear,
464and nothing is written to C<*result>. If the value is > C<UV_MAX>, C<grok_oct>
465returns C<UV_MAX>, sets C<PERL_SCAN_GREATER_THAN_UV_MAX> in the output flags,
2d7f6611 466and writes the value to C<*result> (or the value is discarded if C<result>
796b6530 467is C<NULL>).
7b667b5f 468
2d7f6611 469If C<PERL_SCAN_ALLOW_UNDERSCORES> is set in C<*flags> then the octal
796b6530 470number may use C<"_"> characters to separate digits.
53305cf1
NC
471
472=cut
02470786 473
333ae27c
KW
474Not documented yet because experimental is C<PERL_SCAN_SILENT_NON_PORTABLE>
475which suppresses any message for non-portable numbers, but which are valid
02470786 476on this platform.
53305cf1
NC
477 */
478
479UV
7918f24d
NC
480Perl_grok_oct(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result)
481{
53305cf1
NC
482 const char *s = start;
483 STRLEN len = *len_p;
484 UV value = 0;
485 NV value_nv = 0;
53305cf1 486 const UV max_div_8 = UV_MAX / 8;
f2338a2e 487 const bool allow_underscores = cBOOL(*flags & PERL_SCAN_ALLOW_UNDERSCORES);
53305cf1
NC
488 bool overflowed = FALSE;
489
7918f24d
NC
490 PERL_ARGS_ASSERT_GROK_OCT;
491
53305cf1 492 for (; len-- && *s; s++) {
626ef089 493 if (isOCTAL(*s)) {
53305cf1
NC
494 /* Write it in this wonky order with a goto to attempt to get the
495 compiler to make the common case integer-only loop pretty tight.
496 */
497 redo:
498 if (!overflowed) {
499 if (value <= max_div_8) {
626ef089 500 value = (value << 3) | OCTAL_VALUE(*s);
53305cf1
NC
501 continue;
502 }
503 /* Bah. We're just overflowed. */
dcbac5bb 504 /* diag_listed_as: Integer overflow in %s number */
9b387841
NC
505 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
506 "Integer overflow in octal number");
53305cf1
NC
507 overflowed = TRUE;
508 value_nv = (NV) value;
509 }
510 value_nv *= 8.0;
98994639 511 /* If an NV has not enough bits in its mantissa to
d1be9408 512 * represent a UV this summing of small low-order numbers
98994639
HS
513 * is a waste of time (because the NV cannot preserve
514 * the low-order bits anyway): we could just remember when
53305cf1
NC
515 * did we overflow and in the end just multiply value_nv by the
516 * right amount of 8-tuples. */
626ef089 517 value_nv += (NV) OCTAL_VALUE(*s);
53305cf1
NC
518 continue;
519 }
626ef089
KW
520 if (*s == '_' && len && allow_underscores && isOCTAL(s[1])) {
521 --len;
522 ++s;
523 goto redo;
524 }
53305cf1 525 /* Allow \octal to work the DWIM way (that is, stop scanning
7b667b5f 526 * as soon as non-octal characters are seen, complain only if
626ef089
KW
527 * someone seems to want to use the digits eight and nine. Since we
528 * know it is not octal, then if isDIGIT, must be an 8 or 9). */
529 if (isDIGIT(*s)) {
a2a5de95
NC
530 if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT))
531 Perl_ck_warner(aTHX_ packWARN(WARN_DIGIT),
532 "Illegal octal digit '%c' ignored", *s);
53305cf1
NC
533 }
534 break;
98994639 535 }
19c1206d 536
53305cf1 537 if ( ( overflowed && value_nv > 4294967295.0)
98994639 538#if UVSIZE > 4
02470786
KW
539 || (!overflowed && value > 0xffffffff
540 && ! (*flags & PERL_SCAN_SILENT_NON_PORTABLE))
98994639
HS
541#endif
542 ) {
a2a5de95
NC
543 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
544 "Octal number > 037777777777 non-portable");
53305cf1
NC
545 }
546 *len_p = s - start;
547 if (!overflowed) {
548 *flags = 0;
549 return value;
98994639 550 }
53305cf1
NC
551 *flags = PERL_SCAN_GREATER_THAN_UV_MAX;
552 if (result)
553 *result = value_nv;
554 return UV_MAX;
555}
556
557/*
558=for apidoc scan_bin
559
72d33970 560For backwards compatibility. Use C<grok_bin> instead.
53305cf1
NC
561
562=for apidoc scan_hex
563
72d33970 564For backwards compatibility. Use C<grok_hex> instead.
53305cf1
NC
565
566=for apidoc scan_oct
567
72d33970 568For backwards compatibility. Use C<grok_oct> instead.
53305cf1
NC
569
570=cut
571 */
572
573NV
73d840c0 574Perl_scan_bin(pTHX_ const char *start, STRLEN len, STRLEN *retlen)
53305cf1
NC
575{
576 NV rnv;
577 I32 flags = *retlen ? PERL_SCAN_ALLOW_UNDERSCORES : 0;
73d840c0 578 const UV ruv = grok_bin (start, &len, &flags, &rnv);
53305cf1 579
7918f24d
NC
580 PERL_ARGS_ASSERT_SCAN_BIN;
581
53305cf1
NC
582 *retlen = len;
583 return (flags & PERL_SCAN_GREATER_THAN_UV_MAX) ? rnv : (NV)ruv;
584}
585
586NV
73d840c0 587Perl_scan_oct(pTHX_ const char *start, STRLEN len, STRLEN *retlen)
53305cf1
NC
588{
589 NV rnv;
590 I32 flags = *retlen ? PERL_SCAN_ALLOW_UNDERSCORES : 0;
73d840c0 591 const UV ruv = grok_oct (start, &len, &flags, &rnv);
53305cf1 592
7918f24d
NC
593 PERL_ARGS_ASSERT_SCAN_OCT;
594
53305cf1
NC
595 *retlen = len;
596 return (flags & PERL_SCAN_GREATER_THAN_UV_MAX) ? rnv : (NV)ruv;
597}
598
599NV
73d840c0 600Perl_scan_hex(pTHX_ const char *start, STRLEN len, STRLEN *retlen)
53305cf1
NC
601{
602 NV rnv;
603 I32 flags = *retlen ? PERL_SCAN_ALLOW_UNDERSCORES : 0;
73d840c0 604 const UV ruv = grok_hex (start, &len, &flags, &rnv);
53305cf1 605
7918f24d
NC
606 PERL_ARGS_ASSERT_SCAN_HEX;
607
53305cf1
NC
608 *retlen = len;
609 return (flags & PERL_SCAN_GREATER_THAN_UV_MAX) ? rnv : (NV)ruv;
98994639
HS
610}
611
612/*
613=for apidoc grok_numeric_radix
614
615Scan and skip for a numeric decimal separator (radix).
616
617=cut
618 */
619bool
620Perl_grok_numeric_radix(pTHX_ const char **sp, const char *send)
621{
7918f24d
NC
622 PERL_ARGS_ASSERT_GROK_NUMERIC_RADIX;
623
7ea85fa8
KW
624#ifdef USE_LOCALE_NUMERIC
625
d6ded950 626 if (IN_LC(LC_NUMERIC)) {
f0dafd73
KW
627 STRLEN len;
628 char * radix;
629 bool matches_radix = FALSE;
67d796ae 630 DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
f0dafd73 631
a1395eaf 632 STORE_LC_NUMERIC_FORCE_TO_UNDERLYING();
f0dafd73
KW
633
634 radix = SvPV(PL_numeric_radix_sv, len);
635 radix = savepvn(radix, len);
636
21431899 637 RESTORE_LC_NUMERIC();
f0dafd73
KW
638
639 if (*sp + len <= send) {
640 matches_radix = memEQ(*sp, radix, len);
641 }
642
643 Safefree(radix);
644
645 if (matches_radix) {
646 *sp += len;
647 return TRUE;
648 }
98994639 649 }
f0dafd73 650
98994639 651#endif
7918f24d 652
f0dafd73
KW
653 /* always try "." if numeric radix didn't match because
654 * we may have data from different locales mixed */
98994639
HS
655 if (*sp < send && **sp == '.') {
656 ++*sp;
657 return TRUE;
658 }
f0dafd73 659
98994639
HS
660 return FALSE;
661}
662
569f27e5 663/*
ff4eb398
JH
664=for apidoc grok_infnan
665
796b6530 666Helper for C<grok_number()>, accepts various ways of spelling "infinity"
ff4eb398
JH
667or "not a number", and returns one of the following flag combinations:
668
5962c2f6 669 IS_NUMBER_INFINITY
ff4eb398 670 IS_NUMBER_NAN
5962c2f6 671 IS_NUMBER_INFINITY | IS_NUMBER_NEG
ff4eb398
JH
672 IS_NUMBER_NAN | IS_NUMBER_NEG
673 0
674
796b6530 675possibly |-ed with C<IS_NUMBER_TRAILING>.
b489e20f 676
796b6530 677If an infinity or a not-a-number is recognized, C<*sp> will point to
62bdc035 678one byte past the end of the recognized string. If the recognition fails,
796b6530 679zero is returned, and C<*sp> will not move.
ff4eb398
JH
680
681=cut
682*/
683
684int
3823048b 685Perl_grok_infnan(pTHX_ const char** sp, const char* send)
ff4eb398
JH
686{
687 const char* s = *sp;
688 int flags = 0;
a5dc2484 689#if defined(NV_INF) || defined(NV_NAN)
62bdc035 690 bool odh = FALSE; /* one-dot-hash: 1.#INF */
ff4eb398
JH
691
692 PERL_ARGS_ASSERT_GROK_INFNAN;
693
8c12dc63
JH
694 if (*s == '+') {
695 s++; if (s == send) return 0;
696 }
697 else if (*s == '-') {
ff4eb398
JH
698 flags |= IS_NUMBER_NEG; /* Yes, -NaN happens. Incorrect but happens. */
699 s++; if (s == send) return 0;
700 }
701
702 if (*s == '1') {
62bdc035
JH
703 /* Visual C: 1.#SNAN, -1.#QNAN, 1#INF, 1.#IND (maybe also 1.#NAN)
704 * Let's keep the dot optional. */
ff4eb398
JH
705 s++; if (s == send) return 0;
706 if (*s == '.') {
707 s++; if (s == send) return 0;
708 }
709 if (*s == '#') {
710 s++; if (s == send) return 0;
711 } else
712 return 0;
e855f543 713 odh = TRUE;
ff4eb398
JH
714 }
715
305b8651 716 if (isALPHA_FOLD_EQ(*s, 'I')) {
62bdc035
JH
717 /* INF or IND (1.#IND is "indeterminate", a certain type of NAN) */
718
305b8651 719 s++; if (s == send || isALPHA_FOLD_NE(*s, 'N')) return 0;
ff4eb398 720 s++; if (s == send) return 0;
305b8651 721 if (isALPHA_FOLD_EQ(*s, 'F')) {
ff4eb398 722 s++;
b8974fcb
JH
723 if (s < send && (isALPHA_FOLD_EQ(*s, 'I'))) {
724 int fail =
725 flags | IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT | IS_NUMBER_TRAILING;
726 s++; if (s == send || isALPHA_FOLD_NE(*s, 'N')) return fail;
727 s++; if (s == send || isALPHA_FOLD_NE(*s, 'I')) return fail;
728 s++; if (s == send || isALPHA_FOLD_NE(*s, 'T')) return fail;
729 s++; if (s == send || isALPHA_FOLD_NE(*s, 'Y')) return fail;
3396ed30 730 s++;
b8974fcb
JH
731 } else if (odh) {
732 while (*s == '0') { /* 1.#INF00 */
733 s++;
734 }
3396ed30 735 }
b489e20f
JH
736 while (s < send && isSPACE(*s))
737 s++;
738 if (s < send && *s) {
3396ed30 739 flags |= IS_NUMBER_TRAILING;
fae4db12 740 }
ff4eb398
JH
741 flags |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT;
742 }
e855f543 743 else if (isALPHA_FOLD_EQ(*s, 'D') && odh) { /* 1.#IND */
ff4eb398
JH
744 s++;
745 flags |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT;
fae4db12
JH
746 while (*s == '0') { /* 1.#IND00 */
747 s++;
748 }
1e9aa12f
JH
749 if (*s) {
750 flags |= IS_NUMBER_TRAILING;
751 }
ff4eb398
JH
752 } else
753 return 0;
ff4eb398
JH
754 }
755 else {
62bdc035 756 /* Maybe NAN of some sort */
3823048b
JH
757
758 if (isALPHA_FOLD_EQ(*s, 'S') || isALPHA_FOLD_EQ(*s, 'Q')) {
759 /* snan, qNaN */
760 /* XXX do something with the snan/qnan difference */
761 s++; if (s == send) return 0;
762 }
763
764 if (isALPHA_FOLD_EQ(*s, 'N')) {
765 s++; if (s == send || isALPHA_FOLD_NE(*s, 'A')) return 0;
766 s++; if (s == send || isALPHA_FOLD_NE(*s, 'N')) return 0;
767 s++;
768
769 flags |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT;
770
771 /* NaN can be followed by various stuff (NaNQ, NaNS), but
772 * there are also multiple different NaN values, and some
773 * implementations output the "payload" values,
774 * e.g. NaN123, NAN(abc), while some legacy implementations
775 * have weird stuff like NaN%. */
776 if (isALPHA_FOLD_EQ(*s, 'q') ||
777 isALPHA_FOLD_EQ(*s, 's')) {
778 /* "nanq" or "nans" are ok, though generating
779 * these portably is tricky. */
780 s++;
781 }
782 if (*s == '(') {
783 /* C99 style "nan(123)" or Perlish equivalent "nan($uv)". */
784 const char *t;
785 s++;
786 if (s == send) {
787 return flags | IS_NUMBER_TRAILING;
788 }
789 t = s + 1;
790 while (t < send && *t && *t != ')') {
791 t++;
792 }
793 if (t == send) {
794 return flags | IS_NUMBER_TRAILING;
795 }
796 if (*t == ')') {
797 int nantype;
798 UV nanval;
799 if (s[0] == '0' && s + 2 < t &&
800 isALPHA_FOLD_EQ(s[1], 'x') &&
801 isXDIGIT(s[2])) {
802 STRLEN len = t - s;
803 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
804 nanval = grok_hex(s, &len, &flags, NULL);
805 if ((flags & PERL_SCAN_GREATER_THAN_UV_MAX)) {
806 nantype = 0;
807 } else {
808 nantype = IS_NUMBER_IN_UV;
809 }
810 s += len;
811 } else if (s[0] == '0' && s + 2 < t &&
812 isALPHA_FOLD_EQ(s[1], 'b') &&
813 (s[2] == '0' || s[2] == '1')) {
814 STRLEN len = t - s;
815 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
816 nanval = grok_bin(s, &len, &flags, NULL);
817 if ((flags & PERL_SCAN_GREATER_THAN_UV_MAX)) {
818 nantype = 0;
819 } else {
820 nantype = IS_NUMBER_IN_UV;
821 }
822 s += len;
823 } else {
824 const char *u;
825 nantype =
826 grok_number_flags(s, t - s, &nanval,
827 PERL_SCAN_TRAILING |
828 PERL_SCAN_ALLOW_UNDERSCORES);
829 /* Unfortunately grok_number_flags() doesn't
830 * tell how far we got and the ')' will always
831 * be "trailing", so we need to double-check
832 * whether we had something dubious. */
833 for (u = s; u < t; u++) {
834 if (!isDIGIT(*u)) {
835 flags |= IS_NUMBER_TRAILING;
836 break;
837 }
838 }
839 s = u;
840 }
841
842 /* XXX Doesn't do octal: nan("0123").
843 * Probably not a big loss. */
844
845 if ((nantype & IS_NUMBER_NOT_INT) ||
846 !(nantype && IS_NUMBER_IN_UV)) {
847 /* XXX the nanval is currently unused, that is,
848 * not inserted as the NaN payload of the NV.
849 * But the above code already parses the C99
850 * nan(...) format. See below, and see also
851 * the nan() in POSIX.xs.
852 *
853 * Certain configuration combinations where
854 * NVSIZE is greater than UVSIZE mean that
855 * a single UV cannot contain all the possible
856 * NaN payload bits. There would need to be
857 * some more generic syntax than "nan($uv)".
858 *
859 * Issues to keep in mind:
860 *
861 * (1) In most common cases there would
862 * not be an integral number of bytes that
863 * could be set, only a certain number of bits.
864 * For example for the common case of
865 * NVSIZE == UVSIZE == 8 there is room for 52
866 * bits in the payload, but the most significant
867 * bit is commonly reserved for the
868 * signaling/quiet bit, leaving 51 bits.
869 * Furthermore, the C99 nan() is supposed
870 * to generate quiet NaNs, so it is doubtful
871 * whether it should be able to generate
872 * signaling NaNs. For the x86 80-bit doubles
873 * (if building a long double Perl) there would
874 * be 62 bits (s/q bit being the 63rd).
875 *
876 * (2) Endianness of the payload bits. If the
877 * payload is specified as an UV, the low-order
878 * bits of the UV are naturally little-endianed
879 * (rightmost) bits of the payload. The endianness
880 * of UVs and NVs can be different. */
881 return 0;
882 }
883 if (s < t) {
884 flags |= IS_NUMBER_TRAILING;
885 }
886 } else {
887 /* Looked like nan(...), but no close paren. */
888 flags |= IS_NUMBER_TRAILING;
889 }
890 } else {
891 while (s < send && isSPACE(*s))
892 s++;
893 if (s < send && *s) {
894 /* Note that we here implicitly accept (parse as
895 * "nan", but with warnings) also any other weird
896 * trailing stuff for "nan". In the above we just
897 * check that if we got the C99-style "nan(...)",
898 * the "..." looks sane.
899 * If in future we accept more ways of specifying
900 * the nan payload, the accepting would happen around
901 * here. */
902 flags |= IS_NUMBER_TRAILING;
903 }
904 }
905 s = send;
906 }
907 else
908 return 0;
ff4eb398
JH
909 }
910
b489e20f
JH
911 while (s < send && isSPACE(*s))
912 s++;
913
a5dc2484
JH
914#else
915 PERL_UNUSED_ARG(send);
916#endif /* #if defined(NV_INF) || defined(NV_NAN) */
a1fe7cea
JH
917 *sp = s;
918 return flags;
ff4eb398
JH
919}
920
13393a5e 921/*
3823048b 922=for apidoc grok_number_flags
13393a5e
JH
923
924Recognise (or not) a number. The type of the number is returned
925(0 if unrecognised), otherwise it is a bit-ORed combination of
796b6530
KW
926C<IS_NUMBER_IN_UV>, C<IS_NUMBER_GREATER_THAN_UV_MAX>, C<IS_NUMBER_NOT_INT>,
927C<IS_NUMBER_NEG>, C<IS_NUMBER_INFINITY>, C<IS_NUMBER_NAN> (defined in perl.h).
928
929If the value of the number can fit in a UV, it is returned in C<*valuep>.
930C<IS_NUMBER_IN_UV> will be set to indicate that C<*valuep> is valid, C<IS_NUMBER_IN_UV>
931will never be set unless C<*valuep> is valid, but C<*valuep> may have been assigned
932to during processing even though C<IS_NUMBER_IN_UV> is not set on return.
933If C<valuep> is C<NULL>, C<IS_NUMBER_IN_UV> will be set for the same cases as when
934C<valuep> is non-C<NULL>, but no actual assignment (or SEGV) will occur.
935
936C<IS_NUMBER_NOT_INT> will be set with C<IS_NUMBER_IN_UV> if trailing decimals were
937seen (in which case C<*valuep> gives the true value truncated to an integer), and
938C<IS_NUMBER_NEG> if the number is negative (in which case C<*valuep> holds the
939absolute value). C<IS_NUMBER_IN_UV> is not set if e notation was used or the
13393a5e
JH
940number is larger than a UV.
941
942C<flags> allows only C<PERL_SCAN_TRAILING>, which allows for trailing
943non-numeric text on an otherwise successful I<grok>, setting
944C<IS_NUMBER_TRAILING> on the result.
945
946=for apidoc grok_number
947
796b6530 948Identical to C<grok_number_flags()> with C<flags> set to zero.
13393a5e
JH
949
950=cut
951 */
952int
953Perl_grok_number(pTHX_ const char *pv, STRLEN len, UV *valuep)
954{
955 PERL_ARGS_ASSERT_GROK_NUMBER;
956
957 return grok_number_flags(pv, len, valuep, 0);
958}
959
945b524a
JH
960static const UV uv_max_div_10 = UV_MAX / 10;
961static const U8 uv_max_mod_10 = UV_MAX % 10;
962
3f7602fa 963int
3823048b 964Perl_grok_number_flags(pTHX_ const char *pv, STRLEN len, UV *valuep, U32 flags)
3f7602fa 965{
60939fb8 966 const char *s = pv;
c4420975 967 const char * const send = pv + len;
ae776a2c 968 const char *d;
60939fb8 969 int numtype = 0;
60939fb8 970
3823048b 971 PERL_ARGS_ASSERT_GROK_NUMBER_FLAGS;
7918f24d 972
60939fb8
NC
973 while (s < send && isSPACE(*s))
974 s++;
975 if (s == send) {
976 return 0;
977 } else if (*s == '-') {
978 s++;
979 numtype = IS_NUMBER_NEG;
980 }
981 else if (*s == '+')
aa42a541 982 s++;
60939fb8
NC
983
984 if (s == send)
985 return 0;
986
ae776a2c 987 /* The first digit (after optional sign): note that might
8c12dc63 988 * also point to "infinity" or "nan", or "1.#INF". */
ae776a2c
JH
989 d = s;
990
8c12dc63 991 /* next must be digit or the radix separator or beginning of infinity/nan */
60939fb8
NC
992 if (isDIGIT(*s)) {
993 /* UVs are at least 32 bits, so the first 9 decimal digits cannot
994 overflow. */
995 UV value = *s - '0';
996 /* This construction seems to be more optimiser friendly.
997 (without it gcc does the isDIGIT test and the *s - '0' separately)
998 With it gcc on arm is managing 6 instructions (6 cycles) per digit.
999 In theory the optimiser could deduce how far to unroll the loop
1000 before checking for overflow. */
58bb9ec3
NC
1001 if (++s < send) {
1002 int digit = *s - '0';
f85b645f 1003 if (inRANGE(digit, 0, 9)) {
60939fb8 1004 value = value * 10 + digit;
58bb9ec3
NC
1005 if (++s < send) {
1006 digit = *s - '0';
f85b645f 1007 if (inRANGE(digit, 0, 9)) {
60939fb8 1008 value = value * 10 + digit;
58bb9ec3
NC
1009 if (++s < send) {
1010 digit = *s - '0';
f85b645f 1011 if (inRANGE(digit, 0, 9)) {
60939fb8 1012 value = value * 10 + digit;
58bb9ec3
NC
1013 if (++s < send) {
1014 digit = *s - '0';
f85b645f 1015 if (inRANGE(digit, 0, 9)) {
60939fb8 1016 value = value * 10 + digit;
58bb9ec3
NC
1017 if (++s < send) {
1018 digit = *s - '0';
f85b645f 1019 if (inRANGE(digit, 0, 9)) {
60939fb8 1020 value = value * 10 + digit;
58bb9ec3
NC
1021 if (++s < send) {
1022 digit = *s - '0';
f85b645f 1023 if (inRANGE(digit, 0, 9)) {
60939fb8 1024 value = value * 10 + digit;
58bb9ec3
NC
1025 if (++s < send) {
1026 digit = *s - '0';
f85b645f 1027 if (inRANGE(digit, 0, 9)) {
60939fb8 1028 value = value * 10 + digit;
58bb9ec3
NC
1029 if (++s < send) {
1030 digit = *s - '0';
f85b645f 1031 if (inRANGE(digit, 0, 9)) {
60939fb8 1032 value = value * 10 + digit;
58bb9ec3 1033 if (++s < send) {
60939fb8
NC
1034 /* Now got 9 digits, so need to check
1035 each time for overflow. */
58bb9ec3 1036 digit = *s - '0';
f85b645f 1037 while ( inRANGE(digit, 0, 9)
945b524a
JH
1038 && (value < uv_max_div_10
1039 || (value == uv_max_div_10
1040 && digit <= uv_max_mod_10))) {
60939fb8 1041 value = value * 10 + digit;
58bb9ec3
NC
1042 if (++s < send)
1043 digit = *s - '0';
60939fb8
NC
1044 else
1045 break;
1046 }
f85b645f 1047 if (inRANGE(digit, 0, 9)
51bd16da 1048 && (s < send)) {
60939fb8
NC
1049 /* value overflowed.
1050 skip the remaining digits, don't
1051 worry about setting *valuep. */
1052 do {
1053 s++;
1054 } while (s < send && isDIGIT(*s));
1055 numtype |=
1056 IS_NUMBER_GREATER_THAN_UV_MAX;
1057 goto skip_value;
1058 }
1059 }
1060 }
98994639 1061 }
60939fb8
NC
1062 }
1063 }
1064 }
1065 }
1066 }
1067 }
1068 }
1069 }
1070 }
1071 }
1072 }
98994639 1073 }
60939fb8 1074 }
98994639 1075 }
60939fb8
NC
1076 numtype |= IS_NUMBER_IN_UV;
1077 if (valuep)
1078 *valuep = value;
1079
1080 skip_value:
1081 if (GROK_NUMERIC_RADIX(&s, send)) {
1082 numtype |= IS_NUMBER_NOT_INT;
1083 while (s < send && isDIGIT(*s)) /* optional digits after the radix */
1084 s++;
98994639 1085 }
60939fb8
NC
1086 }
1087 else if (GROK_NUMERIC_RADIX(&s, send)) {
1088 numtype |= IS_NUMBER_NOT_INT | IS_NUMBER_IN_UV; /* valuep assigned below */
1089 /* no digits before the radix means we need digits after it */
1090 if (s < send && isDIGIT(*s)) {
1091 do {
1092 s++;
1093 } while (s < send && isDIGIT(*s));
1094 if (valuep) {
1095 /* integer approximation is valid - it's 0. */
1096 *valuep = 0;
1097 }
98994639 1098 }
60939fb8 1099 else
ae776a2c 1100 return 0;
ff4eb398 1101 }
60939fb8 1102
926f5fc6 1103 if (s > d && s < send) {
60939fb8 1104 /* we can have an optional exponent part */
305b8651 1105 if (isALPHA_FOLD_EQ(*s, 'e')) {
60939fb8
NC
1106 s++;
1107 if (s < send && (*s == '-' || *s == '+'))
1108 s++;
1109 if (s < send && isDIGIT(*s)) {
1110 do {
1111 s++;
1112 } while (s < send && isDIGIT(*s));
1113 }
3f7602fa
TC
1114 else if (flags & PERL_SCAN_TRAILING)
1115 return numtype | IS_NUMBER_TRAILING;
60939fb8 1116 else
3f7602fa
TC
1117 return 0;
1118
1119 /* The only flag we keep is sign. Blow away any "it's UV" */
1120 numtype &= IS_NUMBER_NEG;
1121 numtype |= IS_NUMBER_NOT_INT;
60939fb8
NC
1122 }
1123 }
1124 while (s < send && isSPACE(*s))
1125 s++;
1126 if (s >= send)
aa8b85de 1127 return numtype;
b59bf0b2 1128 if (memEQs(pv, len, "0 but true")) {
60939fb8
NC
1129 if (valuep)
1130 *valuep = 0;
1131 return IS_NUMBER_IN_UV;
1132 }
8c12dc63
JH
1133 /* We could be e.g. at "Inf" or "NaN", or at the "#" of "1.#INF". */
1134 if ((s + 2 < send) && strchr("inqs#", toFOLD(*s))) {
1135 /* Really detect inf/nan. Start at d, not s, since the above
1136 * code might have already consumed the "1." or "1". */
7eff3d39 1137 const int infnan = Perl_grok_infnan(aTHX_ &d, send);
8c12dc63
JH
1138 if ((infnan & IS_NUMBER_INFINITY)) {
1139 return (numtype | infnan); /* Keep sign for infinity. */
1140 }
1141 else if ((infnan & IS_NUMBER_NAN)) {
1142 return (numtype | infnan) & ~IS_NUMBER_NEG; /* Clear sign for nan. */
1143 }
1144 }
3f7602fa
TC
1145 else if (flags & PERL_SCAN_TRAILING) {
1146 return numtype | IS_NUMBER_TRAILING;
1147 }
1148
60939fb8 1149 return 0;
98994639
HS
1150}
1151
6313e544 1152/*
5d4a52b5 1153=for apidoc grok_atoUV
6313e544 1154
5d4a52b5 1155parse a string, looking for a decimal unsigned integer.
338aa8b0 1156
5d4a52b5
KW
1157On entry, C<pv> points to the beginning of the string;
1158C<valptr> points to a UV that will receive the converted value, if found;
1159C<endptr> is either NULL or points to a variable that points to one byte
1160beyond the point in C<pv> that this routine should examine.
1161If C<endptr> is NULL, C<pv> is assumed to be NUL-terminated.
f4379102 1162
5d4a52b5
KW
1163Returns FALSE if C<pv> doesn't represent a valid unsigned integer value (with
1164no leading zeros). Otherwise it returns TRUE, and sets C<*valptr> to that
1165value.
6313e544 1166
5d4a52b5
KW
1167If you constrain the portion of C<pv> that is looked at by this function (by
1168passing a non-NULL C<endptr>), and if the intial bytes of that portion form a
1169valid value, it will return TRUE, setting C<*endptr> to the byte following the
1170final digit of the value. But if there is no constraint at what's looked at,
1171all of C<pv> must be valid in order for TRUE to be returned.
6313e544 1172
5d4a52b5 1173The only characters this accepts are the decimal digits '0'..'9'.
338aa8b0 1174
5d4a52b5
KW
1175As opposed to L<atoi(3)> or L<strtol(3)>, C<grok_atoUV> does NOT allow optional
1176leading whitespace, nor negative inputs. If such features are required, the
1177calling code needs to explicitly implement those.
6313e544 1178
5d4a52b5
KW
1179Note that this function returns FALSE for inputs that would overflow a UV,
1180or have leading zeros. Thus a single C<0> is accepted, but not C<00> nor
1181C<01>, C<002>, I<etc>.
1182
1183Background: C<atoi> has severe problems with illegal inputs, it cannot be
d62b8c6a 1184used for incremental parsing, and therefore should be avoided
5d4a52b5 1185C<atoi> and C<strtol> are also affected by locale settings, which can also be
d62b8c6a
JH
1186seen as a bug (global state controlled by user environment).
1187
238217e5
JK
1188=cut
1189
6313e544
JH
1190*/
1191
22ff3130
HS
1192bool
1193Perl_grok_atoUV(const char *pv, UV *valptr, const char** endptr)
6313e544
JH
1194{
1195 const char* s = pv;
1196 const char** eptr;
1197 const char* end2; /* Used in case endptr is NULL. */
22ff3130 1198 UV val = 0; /* The parsed value. */
6313e544 1199
22ff3130 1200 PERL_ARGS_ASSERT_GROK_ATOUV;
6313e544 1201
5d4a52b5
KW
1202 if (endptr) {
1203 eptr = endptr;
1204 }
1205 else {
1206 end2 = s + strlen(s);
1207 eptr = &end2;
1208 }
1209
1210 if ( *eptr <= s
1211 || ! isDIGIT(*s))
1212 {
1213 return FALSE;
1214 }
1215
97d95d46
KW
1216 /* Single-digit inputs are quite common. */
1217 val = *s++ - '0';
1218 if (s < *eptr && isDIGIT(*s)) {
1219 /* Fail on extra leading zeros. */
1220 if (val == 0)
1221 return FALSE;
1222 while (s < *eptr && isDIGIT(*s)) {
1223 /* This could be unrolled like in grok_number(), but
1224 * the expected uses of this are not speed-needy, and
1225 * unlikely to need full 64-bitness. */
1226 const U8 digit = *s++ - '0';
1227 if (val < uv_max_div_10 ||
1228 (val == uv_max_div_10 && digit <= uv_max_mod_10)) {
1229 val = val * 10 + digit;
1230 } else {
22ff3130 1231 return FALSE;
6313e544
JH
1232 }
1233 }
97d95d46
KW
1234 }
1235
5d4a52b5
KW
1236 if (endptr == NULL) {
1237 if (*s) {
1238 return FALSE; /* If endptr is NULL, no trailing non-digits allowed. */
1239 }
1240 }
1241 else {
1242 *endptr = s;
75feedba 1243 }
97d95d46 1244
22ff3130
HS
1245 *valptr = val;
1246 return TRUE;
6313e544
JH
1247}
1248
ce6f496d 1249#ifndef Perl_strtod
4801ca72 1250STATIC NV
98994639
HS
1251S_mulexp10(NV value, I32 exponent)
1252{
1253 NV result = 1.0;
1254 NV power = 10.0;
1255 bool negative = 0;
1256 I32 bit;
1257
1258 if (exponent == 0)
1259 return value;
659c4b96
DM
1260 if (value == 0)
1261 return (NV)0;
87032ba1 1262
24866caa 1263 /* On OpenVMS VAX we by default use the D_FLOAT double format,
67597c89 1264 * and that format does not have *easy* capabilities [1] for
19c1206d
KW
1265 * overflowing doubles 'silently' as IEEE fp does. We also need
1266 * to support G_FLOAT on both VAX and Alpha, and though the exponent
1267 * range is much larger than D_FLOAT it still doesn't do silent
1268 * overflow. Therefore we need to detect early whether we would
1269 * overflow (this is the behaviour of the native string-to-float
24866caa 1270 * conversion routines, and therefore of native applications, too).
67597c89 1271 *
24866caa
CB
1272 * [1] Trying to establish a condition handler to trap floating point
1273 * exceptions is not a good idea. */
87032ba1
JH
1274
1275 /* In UNICOS and in certain Cray models (such as T90) there is no
1276 * IEEE fp, and no way at all from C to catch fp overflows gracefully.
1277 * There is something you can do if you are willing to use some
1278 * inline assembler: the instruction is called DFI-- but that will
1279 * disable *all* floating point interrupts, a little bit too large
1280 * a hammer. Therefore we need to catch potential overflows before
1281 * it's too late. */
353813d9 1282
a7157111 1283#if ((defined(VMS) && !defined(_IEEE_FP)) || defined(_UNICOS) || defined(DOUBLE_IS_VAX_FLOAT)) && defined(NV_MAX_10_EXP)
353813d9 1284 STMT_START {
c4420975 1285 const NV exp_v = log10(value);
353813d9
HS
1286 if (exponent >= NV_MAX_10_EXP || exponent + exp_v >= NV_MAX_10_EXP)
1287 return NV_MAX;
1288 if (exponent < 0) {
1289 if (-(exponent + exp_v) >= NV_MAX_10_EXP)
1290 return 0.0;
1291 while (-exponent >= NV_MAX_10_EXP) {
1292 /* combination does not overflow, but 10^(-exponent) does */
1293 value /= 10;
1294 ++exponent;
1295 }
1296 }
1297 } STMT_END;
87032ba1
JH
1298#endif
1299
353813d9
HS
1300 if (exponent < 0) {
1301 negative = 1;
1302 exponent = -exponent;
b27804d8
DM
1303#ifdef NV_MAX_10_EXP
1304 /* for something like 1234 x 10^-309, the action of calculating
1305 * the intermediate value 10^309 then returning 1234 / (10^309)
1306 * will fail, since 10^309 becomes infinity. In this case try to
1307 * refactor it as 123 / (10^308) etc.
1308 */
1309 while (value && exponent > NV_MAX_10_EXP) {
1310 exponent--;
1311 value /= 10;
1312 }
48853916
JH
1313 if (value == 0.0)
1314 return value;
b27804d8 1315#endif
353813d9 1316 }
c62e754c
JH
1317#if defined(__osf__)
1318 /* Even with cc -ieee + ieee_set_fp_control(IEEE_TRAP_ENABLE_INV)
1319 * Tru64 fp behavior on inf/nan is somewhat broken. Another way
1320 * to do this would be ieee_set_fp_control(IEEE_TRAP_ENABLE_OVF)
1321 * but that breaks another set of infnan.t tests. */
1322# define FP_OVERFLOWS_TO_ZERO
1323#endif
98994639
HS
1324 for (bit = 1; exponent; bit <<= 1) {
1325 if (exponent & bit) {
1326 exponent ^= bit;
1327 result *= power;
c62e754c
JH
1328#ifdef FP_OVERFLOWS_TO_ZERO
1329 if (result == 0)
a7157111 1330# ifdef NV_INF
c62e754c 1331 return value < 0 ? -NV_INF : NV_INF;
a7157111
JH
1332# else
1333 return value < 0 ? -FLT_MAX : FLT_MAX;
1334# endif
c62e754c 1335#endif
236f0012 1336 /* Floating point exceptions are supposed to be turned off,
19c1206d 1337 * but if we're obviously done, don't risk another iteration.
236f0012
CB
1338 */
1339 if (exponent == 0) break;
98994639
HS
1340 }
1341 power *= power;
1342 }
1343 return negative ? value / result : value * result;
1344}
ce6f496d 1345#endif /* #ifndef Perl_strtod */
98994639 1346
ce6f496d 1347#ifdef Perl_strtod
b93d1309 1348# define ATOF(s, x) my_atof2(s, &x)
f7b64c80 1349#else
b93d1309 1350# define ATOF(s, x) Perl_atof2(s, x)
f7b64c80 1351#endif
b93d1309 1352
98994639
HS
1353NV
1354Perl_my_atof(pTHX_ const char* s)
1355{
f720c878
KW
1356 /* 's' must be NUL terminated */
1357
98994639 1358 NV x = 0.0;
9eda1ea6
KW
1359
1360 PERL_ARGS_ASSERT_MY_ATOF;
1361
b93d1309 1362#if ! defined(USE_LOCALE_NUMERIC)
9eda1ea6 1363
b93d1309 1364 ATOF(s, x);
9eda1ea6
KW
1365
1366#else
7918f24d 1367
a2287a13 1368 {
67d796ae
KW
1369 DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
1370 STORE_LC_NUMERIC_SET_TO_NEEDED();
fdf55d20
KW
1371 if (! (PL_numeric_radix_sv && IN_LC(LC_NUMERIC))) {
1372 ATOF(s,x);
1373 }
1374 else {
19c1206d 1375
e4850248
KW
1376 /* Look through the string for the first thing that looks like a
1377 * decimal point: either the value in the current locale or the
1378 * standard fallback of '.'. The one which appears earliest in the
1379 * input string is the one that we should have atof look for. Note
1380 * that we have to determine this beforehand because on some
1381 * systems, Perl_atof2 is just a wrapper around the system's atof.
1382 * */
1ae85f6c
KW
1383 const char * const standard_pos = strchr(s, '.');
1384 const char * const local_pos
1385 = strstr(s, SvPV_nolen(PL_numeric_radix_sv));
1386 const bool use_standard_radix
1387 = standard_pos && (!local_pos || standard_pos < local_pos);
78787052 1388
665873e9 1389 if (use_standard_radix) {
e4850248 1390 SET_NUMERIC_STANDARD();
665873e9
KW
1391 LOCK_LC_NUMERIC_STANDARD();
1392 }
78787052 1393
b93d1309 1394 ATOF(s,x);
78787052 1395
665873e9
KW
1396 if (use_standard_radix) {
1397 UNLOCK_LC_NUMERIC_STANDARD();
67d796ae 1398 SET_NUMERIC_UNDERLYING();
665873e9 1399 }
e4850248 1400 }
a2287a13
KW
1401 RESTORE_LC_NUMERIC();
1402 }
9eda1ea6 1403
98994639 1404#endif
9eda1ea6 1405
98994639
HS
1406 return x;
1407}
1408
a7157111 1409#if defined(NV_INF) || defined(NV_NAN)
3c81f0b3
DD
1410
1411#ifdef USING_MSVC6
1412# pragma warning(push)
1413# pragma warning(disable:4756;disable:4056)
1414#endif
829757a4 1415static char*
5563f457 1416S_my_atof_infnan(pTHX_ const char* s, bool negative, const char* send, NV* value)
829757a4
JH
1417{
1418 const char *p0 = negative ? s - 1 : s;
1419 const char *p = p0;
7eff3d39 1420 const int infnan = grok_infnan(&p, send);
829757a4
JH
1421 if (infnan && p != p0) {
1422 /* If we can generate inf/nan directly, let's do so. */
1423#ifdef NV_INF
1424 if ((infnan & IS_NUMBER_INFINITY)) {
3823048b 1425 *value = (infnan & IS_NUMBER_NEG) ? -NV_INF: NV_INF;
829757a4
JH
1426 return (char*)p;
1427 }
1428#endif
1429#ifdef NV_NAN
1430 if ((infnan & IS_NUMBER_NAN)) {
3823048b 1431 *value = NV_NAN;
829757a4
JH
1432 return (char*)p;
1433 }
1434#endif
1435#ifdef Perl_strtod
68611e6f 1436 /* If still here, we didn't have either NV_INF or NV_NAN,
829757a4
JH
1437 * and can try falling back to native strtod/strtold.
1438 *
1439 * The native interface might not recognize all the possible
1440 * inf/nan strings Perl recognizes. What we can try
1441 * is to try faking the input. We will try inf/-inf/nan
1442 * as the most promising/portable input. */
1443 {
6d37e916 1444 const char* fake = "silence compiler warning";
829757a4
JH
1445 char* endp;
1446 NV nv;
a7157111 1447#ifdef NV_INF
829757a4
JH
1448 if ((infnan & IS_NUMBER_INFINITY)) {
1449 fake = ((infnan & IS_NUMBER_NEG)) ? "-inf" : "inf";
1450 }
a7157111
JH
1451#endif
1452#ifdef NV_NAN
1453 if ((infnan & IS_NUMBER_NAN)) {
829757a4
JH
1454 fake = "nan";
1455 }
a7157111 1456#endif
6d37e916 1457 assert(strNE(fake, "silence compiler warning"));
9ec8aea5 1458 nv = S_strtod(aTHX_ fake, &endp);
829757a4 1459 if (fake != endp) {
a7157111 1460#ifdef NV_INF
829757a4 1461 if ((infnan & IS_NUMBER_INFINITY)) {
a7157111 1462# ifdef Perl_isinf
829757a4
JH
1463 if (Perl_isinf(nv))
1464 *value = nv;
a7157111 1465# else
829757a4
JH
1466 /* last resort, may generate SIGFPE */
1467 *value = Perl_exp((NV)1e9);
1468 if ((infnan & IS_NUMBER_NEG))
1469 *value = -*value;
a7157111 1470# endif
829757a4
JH
1471 return (char*)p; /* p, not endp */
1472 }
a7157111
JH
1473#endif
1474#ifdef NV_NAN
1475 if ((infnan & IS_NUMBER_NAN)) {
1476# ifdef Perl_isnan
829757a4
JH
1477 if (Perl_isnan(nv))
1478 *value = nv;
a7157111 1479# else
829757a4
JH
1480 /* last resort, may generate SIGFPE */
1481 *value = Perl_log((NV)-1.0);
a7157111 1482# endif
829757a4 1483 return (char*)p; /* p, not endp */
a7157111 1484#endif
829757a4
JH
1485 }
1486 }
1487 }
1488#endif /* #ifdef Perl_strtod */
1489 }
1490 return NULL;
1491}
3c81f0b3
DD
1492#ifdef USING_MSVC6
1493# pragma warning(pop)
1494#endif
829757a4 1495
a7157111
JH
1496#endif /* if defined(NV_INF) || defined(NV_NAN) */
1497
98994639
HS
1498char*
1499Perl_my_atof2(pTHX_ const char* orig, NV* value)
1500{
6928bedc
KW
1501 PERL_ARGS_ASSERT_MY_ATOF2;
1502 return my_atof3(orig, value, 0);
1503}
1504
1505char*
16411967 1506Perl_my_atof3(pTHX_ const char* orig, NV* value, const STRLEN len)
6928bedc 1507{
e1ec3a88 1508 const char* s = orig;
a4eca1d4 1509 NV result[3] = {0.0, 0.0, 0.0};
ce6f496d 1510#if defined(USE_PERL_ATOF) || defined(Perl_strtod)
6928bedc
KW
1511 const char* send = s + ((len != 0)
1512 ? len
1513 : strlen(orig)); /* one past the last */
a4eca1d4
JH
1514 bool negative = 0;
1515#endif
ce6f496d 1516#if defined(USE_PERL_ATOF) && !defined(Perl_strtod)
a4eca1d4 1517 UV accumulator[2] = {0,0}; /* before/after dp */
8194bf88 1518 bool seen_digit = 0;
20f6aaab
AS
1519 I32 exp_adjust[2] = {0,0};
1520 I32 exp_acc[2] = {-1, -1};
1521 /* the current exponent adjust for the accumulators */
98994639 1522 I32 exponent = 0;
8194bf88 1523 I32 seen_dp = 0;
20f6aaab
AS
1524 I32 digit = 0;
1525 I32 old_digit = 0;
8194bf88 1526 I32 sig_digits = 0; /* noof significant digits seen so far */
a4eca1d4 1527#endif
8194bf88 1528
ce6f496d 1529#if defined(USE_PERL_ATOF) || defined(Perl_strtod)
6928bedc 1530 PERL_ARGS_ASSERT_MY_ATOF3;
7918f24d 1531
a4eca1d4 1532 /* leading whitespace */
6928bedc 1533 while (s < send && isSPACE(*s))
a4eca1d4
JH
1534 ++s;
1535
1536 /* sign */
1537 switch (*s) {
1538 case '-':
1539 negative = 1;
1540 /* FALLTHROUGH */
1541 case '+':
1542 ++s;
1543 }
1544#endif
1545
ce6f496d 1546#ifdef Perl_strtod
a4eca1d4
JH
1547 {
1548 char* endp;
d94e901a
KW
1549 char* copy = NULL;
1550
adc55e02 1551 if ((endp = S_my_atof_infnan(aTHX_ s, negative, send, value)))
a4eca1d4 1552 return endp;
d94e901a
KW
1553
1554 /* If the length is passed in, the input string isn't NUL-terminated,
1555 * and in it turns out the function below assumes it is; therefore we
1556 * create a copy and NUL-terminate that */
1557 if (len) {
1558 Newx(copy, len + 1, char);
1559 Copy(orig, copy, len, char);
1560 copy[len] = '\0';
1561 s = copy + (s - orig);
1562 }
1563
9ec8aea5 1564 result[2] = S_strtod(aTHX_ s, &endp);
d94e901a
KW
1565
1566 /* If we created a copy, 'endp' is in terms of that. Convert back to
1567 * the original */
1568 if (copy) {
aac39b03 1569 s = (s - copy) + (char *) orig;
d94e901a
KW
1570 endp = (endp - copy) + (char *) orig;
1571 Safefree(copy);
1572 }
1573
a4eca1d4
JH
1574 if (s != endp) {
1575 *value = negative ? -result[2] : result[2];
1576 return endp;
1577 }
1578 return NULL;
1579 }
1580#elif defined(USE_PERL_ATOF)
1581
8194bf88
DM
1582/* There is no point in processing more significant digits
1583 * than the NV can hold. Note that NV_DIG is a lower-bound value,
1584 * while we need an upper-bound value. We add 2 to account for this;
1585 * since it will have been conservative on both the first and last digit.
1586 * For example a 32-bit mantissa with an exponent of 4 would have
1587 * exact values in the set
1588 * 4
1589 * 8
1590 * ..
1591 * 17179869172
1592 * 17179869176
1593 * 17179869180
1594 *
1595 * where for the purposes of calculating NV_DIG we would have to discount
1596 * both the first and last digit, since neither can hold all values from
1597 * 0..9; but for calculating the value we must examine those two digits.
1598 */
ffa277e5
EAS
1599#ifdef MAX_SIG_DIG_PLUS
1600 /* It is not necessarily the case that adding 2 to NV_DIG gets all the
1601 possible digits in a NV, especially if NVs are not IEEE compliant
1602 (e.g., long doubles on IRIX) - Allen <allens@cpan.org> */
1603# define MAX_SIG_DIGITS (NV_DIG+MAX_SIG_DIG_PLUS)
1604#else
1605# define MAX_SIG_DIGITS (NV_DIG+2)
1606#endif
8194bf88
DM
1607
1608/* the max number we can accumulate in a UV, and still safely do 10*N+9 */
1609#define MAX_ACCUMULATE ( (UV) ((UV_MAX - 9)/10))
98994639 1610
a5dc2484 1611#if defined(NV_INF) || defined(NV_NAN)
ae776a2c 1612 {
7eff3d39 1613 char* endp;
5563f457 1614 if ((endp = S_my_atof_infnan(aTHX_ s, negative, send, value)))
7eff3d39 1615 return endp;
ae776a2c 1616 }
a5dc2484 1617#endif
2b54f59f 1618
8194bf88
DM
1619 /* we accumulate digits into an integer; when this becomes too
1620 * large, we add the total to NV and start again */
98994639 1621
6928bedc 1622 while (s < send) {
8194bf88
DM
1623 if (isDIGIT(*s)) {
1624 seen_digit = 1;
20f6aaab 1625 old_digit = digit;
8194bf88 1626 digit = *s++ - '0';
20f6aaab
AS
1627 if (seen_dp)
1628 exp_adjust[1]++;
98994639 1629
8194bf88
DM
1630 /* don't start counting until we see the first significant
1631 * digit, eg the 5 in 0.00005... */
1632 if (!sig_digits && digit == 0)
1633 continue;
1634
1635 if (++sig_digits > MAX_SIG_DIGITS) {
98994639 1636 /* limits of precision reached */
20f6aaab
AS
1637 if (digit > 5) {
1638 ++accumulator[seen_dp];
1639 } else if (digit == 5) {
1640 if (old_digit % 2) { /* round to even - Allen */
1641 ++accumulator[seen_dp];
1642 }
1643 }
1644 if (seen_dp) {
1645 exp_adjust[1]--;
1646 } else {
1647 exp_adjust[0]++;
1648 }
8194bf88 1649 /* skip remaining digits */
6928bedc 1650 while (s < send && isDIGIT(*s)) {
98994639 1651 ++s;
20f6aaab
AS
1652 if (! seen_dp) {
1653 exp_adjust[0]++;
1654 }
98994639
HS
1655 }
1656 /* warn of loss of precision? */
98994639 1657 }
8194bf88 1658 else {
20f6aaab 1659 if (accumulator[seen_dp] > MAX_ACCUMULATE) {
8194bf88 1660 /* add accumulator to result and start again */
20f6aaab
AS
1661 result[seen_dp] = S_mulexp10(result[seen_dp],
1662 exp_acc[seen_dp])
1663 + (NV)accumulator[seen_dp];
1664 accumulator[seen_dp] = 0;
1665 exp_acc[seen_dp] = 0;
98994639 1666 }
20f6aaab
AS
1667 accumulator[seen_dp] = accumulator[seen_dp] * 10 + digit;
1668 ++exp_acc[seen_dp];
98994639 1669 }
8194bf88 1670 }
e1ec3a88 1671 else if (!seen_dp && GROK_NUMERIC_RADIX(&s, send)) {
8194bf88 1672 seen_dp = 1;
20f6aaab 1673 if (sig_digits > MAX_SIG_DIGITS) {
6928bedc 1674 while (s < send && isDIGIT(*s)) {
20f6aaab 1675 ++s;
9604fbf0 1676 }
20f6aaab
AS
1677 break;
1678 }
8194bf88
DM
1679 }
1680 else {
1681 break;
98994639
HS
1682 }
1683 }
1684
20f6aaab
AS
1685 result[0] = S_mulexp10(result[0], exp_acc[0]) + (NV)accumulator[0];
1686 if (seen_dp) {
1687 result[1] = S_mulexp10(result[1], exp_acc[1]) + (NV)accumulator[1];
1688 }
98994639 1689
6928bedc 1690 if (s < send && seen_digit && (isALPHA_FOLD_EQ(*s, 'e'))) {
98994639
HS
1691 bool expnegative = 0;
1692
1693 ++s;
1694 switch (*s) {
1695 case '-':
1696 expnegative = 1;
924ba076 1697 /* FALLTHROUGH */
98994639
HS
1698 case '+':
1699 ++s;
1700 }
6928bedc 1701 while (s < send && isDIGIT(*s))
98994639
HS
1702 exponent = exponent * 10 + (*s++ - '0');
1703 if (expnegative)
1704 exponent = -exponent;
1705 }
1706
1707 /* now apply the exponent */
20f6aaab
AS
1708
1709 if (seen_dp) {
1710 result[2] = S_mulexp10(result[0],exponent+exp_adjust[0])
1711 + S_mulexp10(result[1],exponent-exp_adjust[1]);
1712 } else {
1713 result[2] = S_mulexp10(result[0],exponent+exp_adjust[0]);
1714 }
98994639
HS
1715
1716 /* now apply the sign */
1717 if (negative)
20f6aaab 1718 result[2] = -result[2];
a36244b7 1719#endif /* USE_PERL_ATOF */
20f6aaab 1720 *value = result[2];
73d840c0 1721 return (char *)s;
98994639
HS
1722}
1723
5d34af89 1724/*
3d9d9213 1725=for apidoc isinfnan
5d34af89 1726
796b6530
KW
1727C<Perl_isinfnan()> is utility function that returns true if the NV
1728argument is either an infinity or a C<NaN>, false otherwise. To test
1729in more detail, use C<Perl_isinf()> and C<Perl_isnan()>.
5d34af89 1730
68611e6f
JH
1731This is also the logical inverse of Perl_isfinite().
1732
5d34af89
JH
1733=cut
1734*/
1cd88304
JH
1735bool
1736Perl_isinfnan(NV nv)
1737{
a5dc2484 1738 PERL_UNUSED_ARG(nv);
1cd88304
JH
1739#ifdef Perl_isinf
1740 if (Perl_isinf(nv))
1741 return TRUE;
1742#endif
1743#ifdef Perl_isnan
1744 if (Perl_isnan(nv))
1745 return TRUE;
1746#endif
1747 return FALSE;
1748}
1749
354b74ae
FC
1750/*
1751=for apidoc
1752
796b6530 1753Checks whether the argument would be either an infinity or C<NaN> when used
354b74ae 1754as a number, but is careful not to trigger non-numeric or uninitialized
796b6530 1755warnings. it assumes the caller has done C<SvGETMAGIC(sv)> already.
354b74ae
FC
1756
1757=cut
1758*/
1759
1760bool
1761Perl_isinfnansv(pTHX_ SV *sv)
1762{
1763 PERL_ARGS_ASSERT_ISINFNANSV;
1764 if (!SvOK(sv))
1765 return FALSE;
1766 if (SvNOKp(sv))
1767 return Perl_isinfnan(SvNVX(sv));
1768 if (SvIOKp(sv))
1769 return FALSE;
1770 {
1771 STRLEN len;
1772 const char *s = SvPV_nomg_const(sv, len);
3823048b 1773 return cBOOL(grok_infnan(&s, s+len));
354b74ae
FC
1774 }
1775}
1776
d67dac15 1777#ifndef HAS_MODFL
68611e6f
JH
1778/* C99 has truncl, pre-C99 Solaris had aintl. We can use either with
1779 * copysignl to emulate modfl, which is in some platforms missing or
1780 * broken. */
d67dac15
JH
1781# if defined(HAS_TRUNCL) && defined(HAS_COPYSIGNL)
1782long double
1783Perl_my_modfl(long double x, long double *ip)
1784{
68611e6f
JH
1785 *ip = truncl(x);
1786 return (x == *ip ? copysignl(0.0L, x) : x - *ip);
d67dac15
JH
1787}
1788# elif defined(HAS_AINTL) && defined(HAS_COPYSIGNL)
55954f19
JH
1789long double
1790Perl_my_modfl(long double x, long double *ip)
1791{
68611e6f
JH
1792 *ip = aintl(x);
1793 return (x == *ip ? copysignl(0.0L, x) : x - *ip);
55954f19 1794}
d67dac15 1795# endif
55954f19
JH
1796#endif
1797
7b9b7dff 1798/* Similarly, with ilogbl and scalbnl we can emulate frexpl. */
55954f19
JH
1799#if ! defined(HAS_FREXPL) && defined(HAS_ILOGBL) && defined(HAS_SCALBNL)
1800long double
1801Perl_my_frexpl(long double x, int *e) {
68611e6f
JH
1802 *e = x == 0.0L ? 0 : ilogbl(x) + 1;
1803 return (scalbnl(x, -*e));
55954f19
JH
1804}
1805#endif
66610fdd
RGS
1806
1807/*
ed140128
AD
1808=for apidoc Perl_signbit
1809
1810Return a non-zero integer if the sign bit on an NV is set, and 0 if
19c1206d 1811it is not.
ed140128 1812
796b6530
KW
1813If F<Configure> detects this system has a C<signbit()> that will work with
1814our NVs, then we just use it via the C<#define> in F<perl.h>. Otherwise,
8b7fad81 1815fall back on this implementation. The main use of this function
796b6530 1816is catching C<-0.0>.
ed140128 1817
796b6530
KW
1818C<Configure> notes: This function is called C<'Perl_signbit'> instead of a
1819plain C<'signbit'> because it is easy to imagine a system having a C<signbit()>
ed140128 1820function or macro that doesn't happen to work with our particular choice
796b6530 1821of NVs. We shouldn't just re-C<#define> C<signbit> as C<Perl_signbit> and expect
ed140128 1822the standard system headers to be happy. Also, this is a no-context
796b6530
KW
1823function (no C<pTHX_>) because C<Perl_signbit()> is usually re-C<#defined> in
1824F<perl.h> as a simple macro call to the system's C<signbit()>.
1825Users should just always call C<Perl_signbit()>.
ed140128
AD
1826
1827=cut
1828*/
1829#if !defined(HAS_SIGNBIT)
1830int
1831Perl_signbit(NV x) {
8b7fad81 1832# ifdef Perl_fp_class_nzero
406d5545
JH
1833 return Perl_fp_class_nzero(x);
1834 /* Try finding the high byte, and assume it's highest bit
1835 * is the sign. This assumption is probably wrong somewhere. */
572cd850
JH
1836# elif defined(USE_LONG_DOUBLE) && LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_LITTLE_ENDIAN
1837 return (((unsigned char *)&x)[9] & 0x80);
1838# elif defined(NV_LITTLE_ENDIAN)
1839 /* Note that NVSIZE is sizeof(NV), which would make the below be
1840 * wrong if the end bytes are unused, which happens with the x86
1841 * 80-bit long doubles, which is why take care of that above. */
1842 return (((unsigned char *)&x)[NVSIZE - 1] & 0x80);
1843# elif defined(NV_BIG_ENDIAN)
1844 return (((unsigned char *)&x)[0] & 0x80);
1845# else
406d5545 1846 /* This last resort fallback is wrong for the negative zero. */
3585840c 1847 return (x < 0.0) ? 1 : 0;
572cd850 1848# endif
ed140128
AD
1849}
1850#endif
1851
1852/*
14d04a33 1853 * ex: set ts=8 sts=4 sw=4 et:
37442d52 1854 */