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