This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
PATCH: GH #17367 read 1 beyond end of buffer
[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;
783
784 /* NaN can be followed by various stuff (NaNQ, NaNS), but
785 * there are also multiple different NaN values, and some
786 * implementations output the "payload" values,
787 * e.g. NaN123, NAN(abc), while some legacy implementations
788 * have weird stuff like NaN%. */
789 if (isALPHA_FOLD_EQ(*s, 'q') ||
790 isALPHA_FOLD_EQ(*s, 's')) {
791 /* "nanq" or "nans" are ok, though generating
792 * these portably is tricky. */
793 s++;
81d11450
KW
794 if (s == send) {
795 return flags;
796 }
3823048b
JH
797 }
798 if (*s == '(') {
799 /* C99 style "nan(123)" or Perlish equivalent "nan($uv)". */
800 const char *t;
801 s++;
802 if (s == send) {
803 return flags | IS_NUMBER_TRAILING;
804 }
805 t = s + 1;
806 while (t < send && *t && *t != ')') {
807 t++;
808 }
809 if (t == send) {
810 return flags | IS_NUMBER_TRAILING;
811 }
812 if (*t == ')') {
813 int nantype;
814 UV nanval;
815 if (s[0] == '0' && s + 2 < t &&
816 isALPHA_FOLD_EQ(s[1], 'x') &&
817 isXDIGIT(s[2])) {
818 STRLEN len = t - s;
819 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
820 nanval = grok_hex(s, &len, &flags, NULL);
821 if ((flags & PERL_SCAN_GREATER_THAN_UV_MAX)) {
822 nantype = 0;
823 } else {
824 nantype = IS_NUMBER_IN_UV;
825 }
826 s += len;
827 } else if (s[0] == '0' && s + 2 < t &&
828 isALPHA_FOLD_EQ(s[1], 'b') &&
829 (s[2] == '0' || s[2] == '1')) {
830 STRLEN len = t - s;
831 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
832 nanval = grok_bin(s, &len, &flags, NULL);
833 if ((flags & PERL_SCAN_GREATER_THAN_UV_MAX)) {
834 nantype = 0;
835 } else {
836 nantype = IS_NUMBER_IN_UV;
837 }
838 s += len;
839 } else {
840 const char *u;
841 nantype =
842 grok_number_flags(s, t - s, &nanval,
843 PERL_SCAN_TRAILING |
844 PERL_SCAN_ALLOW_UNDERSCORES);
845 /* Unfortunately grok_number_flags() doesn't
846 * tell how far we got and the ')' will always
847 * be "trailing", so we need to double-check
848 * whether we had something dubious. */
849 for (u = s; u < t; u++) {
850 if (!isDIGIT(*u)) {
851 flags |= IS_NUMBER_TRAILING;
852 break;
853 }
854 }
855 s = u;
856 }
857
858 /* XXX Doesn't do octal: nan("0123").
859 * Probably not a big loss. */
860
861 if ((nantype & IS_NUMBER_NOT_INT) ||
862 !(nantype && IS_NUMBER_IN_UV)) {
863 /* XXX the nanval is currently unused, that is,
864 * not inserted as the NaN payload of the NV.
865 * But the above code already parses the C99
866 * nan(...) format. See below, and see also
867 * the nan() in POSIX.xs.
868 *
869 * Certain configuration combinations where
870 * NVSIZE is greater than UVSIZE mean that
871 * a single UV cannot contain all the possible
872 * NaN payload bits. There would need to be
873 * some more generic syntax than "nan($uv)".
874 *
875 * Issues to keep in mind:
876 *
877 * (1) In most common cases there would
878 * not be an integral number of bytes that
879 * could be set, only a certain number of bits.
880 * For example for the common case of
881 * NVSIZE == UVSIZE == 8 there is room for 52
882 * bits in the payload, but the most significant
883 * bit is commonly reserved for the
884 * signaling/quiet bit, leaving 51 bits.
885 * Furthermore, the C99 nan() is supposed
886 * to generate quiet NaNs, so it is doubtful
887 * whether it should be able to generate
888 * signaling NaNs. For the x86 80-bit doubles
889 * (if building a long double Perl) there would
890 * be 62 bits (s/q bit being the 63rd).
891 *
892 * (2) Endianness of the payload bits. If the
893 * payload is specified as an UV, the low-order
894 * bits of the UV are naturally little-endianed
895 * (rightmost) bits of the payload. The endianness
896 * of UVs and NVs can be different. */
897 return 0;
898 }
899 if (s < t) {
900 flags |= IS_NUMBER_TRAILING;
901 }
902 } else {
903 /* Looked like nan(...), but no close paren. */
904 flags |= IS_NUMBER_TRAILING;
905 }
906 } else {
907 while (s < send && isSPACE(*s))
908 s++;
909 if (s < send && *s) {
910 /* Note that we here implicitly accept (parse as
911 * "nan", but with warnings) also any other weird
912 * trailing stuff for "nan". In the above we just
913 * check that if we got the C99-style "nan(...)",
914 * the "..." looks sane.
915 * If in future we accept more ways of specifying
916 * the nan payload, the accepting would happen around
917 * here. */
918 flags |= IS_NUMBER_TRAILING;
919 }
920 }
921 s = send;
922 }
923 else
924 return 0;
ff4eb398
JH
925 }
926
b489e20f
JH
927 while (s < send && isSPACE(*s))
928 s++;
929
a5dc2484
JH
930#else
931 PERL_UNUSED_ARG(send);
932#endif /* #if defined(NV_INF) || defined(NV_NAN) */
a1fe7cea
JH
933 *sp = s;
934 return flags;
ff4eb398
JH
935}
936
13393a5e 937/*
3823048b 938=for apidoc grok_number_flags
13393a5e
JH
939
940Recognise (or not) a number. The type of the number is returned
941(0 if unrecognised), otherwise it is a bit-ORed combination of
796b6530
KW
942C<IS_NUMBER_IN_UV>, C<IS_NUMBER_GREATER_THAN_UV_MAX>, C<IS_NUMBER_NOT_INT>,
943C<IS_NUMBER_NEG>, C<IS_NUMBER_INFINITY>, C<IS_NUMBER_NAN> (defined in perl.h).
944
945If the value of the number can fit in a UV, it is returned in C<*valuep>.
946C<IS_NUMBER_IN_UV> will be set to indicate that C<*valuep> is valid, C<IS_NUMBER_IN_UV>
947will never be set unless C<*valuep> is valid, but C<*valuep> may have been assigned
948to during processing even though C<IS_NUMBER_IN_UV> is not set on return.
949If C<valuep> is C<NULL>, C<IS_NUMBER_IN_UV> will be set for the same cases as when
950C<valuep> is non-C<NULL>, but no actual assignment (or SEGV) will occur.
951
952C<IS_NUMBER_NOT_INT> will be set with C<IS_NUMBER_IN_UV> if trailing decimals were
953seen (in which case C<*valuep> gives the true value truncated to an integer), and
954C<IS_NUMBER_NEG> if the number is negative (in which case C<*valuep> holds the
955absolute value). C<IS_NUMBER_IN_UV> is not set if e notation was used or the
13393a5e
JH
956number is larger than a UV.
957
958C<flags> allows only C<PERL_SCAN_TRAILING>, which allows for trailing
959non-numeric text on an otherwise successful I<grok>, setting
960C<IS_NUMBER_TRAILING> on the result.
961
962=for apidoc grok_number
963
796b6530 964Identical to C<grok_number_flags()> with C<flags> set to zero.
13393a5e
JH
965
966=cut
967 */
968int
969Perl_grok_number(pTHX_ const char *pv, STRLEN len, UV *valuep)
970{
971 PERL_ARGS_ASSERT_GROK_NUMBER;
972
973 return grok_number_flags(pv, len, valuep, 0);
974}
975
945b524a
JH
976static const UV uv_max_div_10 = UV_MAX / 10;
977static const U8 uv_max_mod_10 = UV_MAX % 10;
978
3f7602fa 979int
3823048b 980Perl_grok_number_flags(pTHX_ const char *pv, STRLEN len, UV *valuep, U32 flags)
3f7602fa 981{
60939fb8 982 const char *s = pv;
c4420975 983 const char * const send = pv + len;
ae776a2c 984 const char *d;
60939fb8 985 int numtype = 0;
60939fb8 986
3823048b 987 PERL_ARGS_ASSERT_GROK_NUMBER_FLAGS;
7918f24d 988
60939fb8
NC
989 while (s < send && isSPACE(*s))
990 s++;
991 if (s == send) {
992 return 0;
993 } else if (*s == '-') {
994 s++;
995 numtype = IS_NUMBER_NEG;
996 }
997 else if (*s == '+')
aa42a541 998 s++;
60939fb8
NC
999
1000 if (s == send)
1001 return 0;
1002
ae776a2c 1003 /* The first digit (after optional sign): note that might
8c12dc63 1004 * also point to "infinity" or "nan", or "1.#INF". */
ae776a2c
JH
1005 d = s;
1006
8c12dc63 1007 /* next must be digit or the radix separator or beginning of infinity/nan */
60939fb8
NC
1008 if (isDIGIT(*s)) {
1009 /* UVs are at least 32 bits, so the first 9 decimal digits cannot
1010 overflow. */
1011 UV value = *s - '0';
1012 /* This construction seems to be more optimiser friendly.
1013 (without it gcc does the isDIGIT test and the *s - '0' separately)
1014 With it gcc on arm is managing 6 instructions (6 cycles) per digit.
1015 In theory the optimiser could deduce how far to unroll the loop
1016 before checking for overflow. */
58bb9ec3
NC
1017 if (++s < send) {
1018 int 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
NC
1033 if (++s < send) {
1034 digit = *s - '0';
f85b645f 1035 if (inRANGE(digit, 0, 9)) {
60939fb8 1036 value = value * 10 + digit;
58bb9ec3
NC
1037 if (++s < send) {
1038 digit = *s - '0';
f85b645f 1039 if (inRANGE(digit, 0, 9)) {
60939fb8 1040 value = value * 10 + digit;
58bb9ec3
NC
1041 if (++s < send) {
1042 digit = *s - '0';
f85b645f 1043 if (inRANGE(digit, 0, 9)) {
60939fb8 1044 value = value * 10 + digit;
58bb9ec3
NC
1045 if (++s < send) {
1046 digit = *s - '0';
f85b645f 1047 if (inRANGE(digit, 0, 9)) {
60939fb8 1048 value = value * 10 + digit;
58bb9ec3 1049 if (++s < send) {
60939fb8
NC
1050 /* Now got 9 digits, so need to check
1051 each time for overflow. */
58bb9ec3 1052 digit = *s - '0';
f85b645f 1053 while ( inRANGE(digit, 0, 9)
945b524a
JH
1054 && (value < uv_max_div_10
1055 || (value == uv_max_div_10
1056 && digit <= uv_max_mod_10))) {
60939fb8 1057 value = value * 10 + digit;
58bb9ec3
NC
1058 if (++s < send)
1059 digit = *s - '0';
60939fb8
NC
1060 else
1061 break;
1062 }
f85b645f 1063 if (inRANGE(digit, 0, 9)
51bd16da 1064 && (s < send)) {
60939fb8
NC
1065 /* value overflowed.
1066 skip the remaining digits, don't
1067 worry about setting *valuep. */
1068 do {
1069 s++;
1070 } while (s < send && isDIGIT(*s));
1071 numtype |=
1072 IS_NUMBER_GREATER_THAN_UV_MAX;
1073 goto skip_value;
1074 }
1075 }
1076 }
98994639 1077 }
60939fb8
NC
1078 }
1079 }
1080 }
1081 }
1082 }
1083 }
1084 }
1085 }
1086 }
1087 }
1088 }
98994639 1089 }
60939fb8 1090 }
98994639 1091 }
60939fb8
NC
1092 numtype |= IS_NUMBER_IN_UV;
1093 if (valuep)
1094 *valuep = value;
1095
1096 skip_value:
1097 if (GROK_NUMERIC_RADIX(&s, send)) {
1098 numtype |= IS_NUMBER_NOT_INT;
1099 while (s < send && isDIGIT(*s)) /* optional digits after the radix */
1100 s++;
98994639 1101 }
60939fb8
NC
1102 }
1103 else if (GROK_NUMERIC_RADIX(&s, send)) {
1104 numtype |= IS_NUMBER_NOT_INT | IS_NUMBER_IN_UV; /* valuep assigned below */
1105 /* no digits before the radix means we need digits after it */
1106 if (s < send && isDIGIT(*s)) {
1107 do {
1108 s++;
1109 } while (s < send && isDIGIT(*s));
1110 if (valuep) {
1111 /* integer approximation is valid - it's 0. */
1112 *valuep = 0;
1113 }
98994639 1114 }
60939fb8 1115 else
ae776a2c 1116 return 0;
ff4eb398 1117 }
60939fb8 1118
926f5fc6 1119 if (s > d && s < send) {
60939fb8 1120 /* we can have an optional exponent part */
305b8651 1121 if (isALPHA_FOLD_EQ(*s, 'e')) {
60939fb8
NC
1122 s++;
1123 if (s < send && (*s == '-' || *s == '+'))
1124 s++;
1125 if (s < send && isDIGIT(*s)) {
1126 do {
1127 s++;
1128 } while (s < send && isDIGIT(*s));
1129 }
3f7602fa
TC
1130 else if (flags & PERL_SCAN_TRAILING)
1131 return numtype | IS_NUMBER_TRAILING;
60939fb8 1132 else
3f7602fa
TC
1133 return 0;
1134
1135 /* The only flag we keep is sign. Blow away any "it's UV" */
1136 numtype &= IS_NUMBER_NEG;
1137 numtype |= IS_NUMBER_NOT_INT;
60939fb8
NC
1138 }
1139 }
1140 while (s < send && isSPACE(*s))
1141 s++;
1142 if (s >= send)
aa8b85de 1143 return numtype;
b59bf0b2 1144 if (memEQs(pv, len, "0 but true")) {
60939fb8
NC
1145 if (valuep)
1146 *valuep = 0;
1147 return IS_NUMBER_IN_UV;
1148 }
8c12dc63
JH
1149 /* We could be e.g. at "Inf" or "NaN", or at the "#" of "1.#INF". */
1150 if ((s + 2 < send) && strchr("inqs#", toFOLD(*s))) {
1151 /* Really detect inf/nan. Start at d, not s, since the above
1152 * code might have already consumed the "1." or "1". */
7eff3d39 1153 const int infnan = Perl_grok_infnan(aTHX_ &d, send);
8c12dc63
JH
1154 if ((infnan & IS_NUMBER_INFINITY)) {
1155 return (numtype | infnan); /* Keep sign for infinity. */
1156 }
1157 else if ((infnan & IS_NUMBER_NAN)) {
1158 return (numtype | infnan) & ~IS_NUMBER_NEG; /* Clear sign for nan. */
1159 }
1160 }
3f7602fa
TC
1161 else if (flags & PERL_SCAN_TRAILING) {
1162 return numtype | IS_NUMBER_TRAILING;
1163 }
1164
60939fb8 1165 return 0;
98994639
HS
1166}
1167
6313e544 1168/*
5d4a52b5 1169=for apidoc grok_atoUV
6313e544 1170
5d4a52b5 1171parse a string, looking for a decimal unsigned integer.
338aa8b0 1172
5d4a52b5
KW
1173On entry, C<pv> points to the beginning of the string;
1174C<valptr> points to a UV that will receive the converted value, if found;
1175C<endptr> is either NULL or points to a variable that points to one byte
1176beyond the point in C<pv> that this routine should examine.
1177If C<endptr> is NULL, C<pv> is assumed to be NUL-terminated.
f4379102 1178
5d4a52b5
KW
1179Returns FALSE if C<pv> doesn't represent a valid unsigned integer value (with
1180no leading zeros). Otherwise it returns TRUE, and sets C<*valptr> to that
1181value.
6313e544 1182
5d4a52b5
KW
1183If you constrain the portion of C<pv> that is looked at by this function (by
1184passing a non-NULL C<endptr>), and if the intial bytes of that portion form a
1185valid value, it will return TRUE, setting C<*endptr> to the byte following the
1186final digit of the value. But if there is no constraint at what's looked at,
1187all of C<pv> must be valid in order for TRUE to be returned.
6313e544 1188
5d4a52b5 1189The only characters this accepts are the decimal digits '0'..'9'.
338aa8b0 1190
5d4a52b5
KW
1191As opposed to L<atoi(3)> or L<strtol(3)>, C<grok_atoUV> does NOT allow optional
1192leading whitespace, nor negative inputs. If such features are required, the
1193calling code needs to explicitly implement those.
6313e544 1194
5d4a52b5
KW
1195Note that this function returns FALSE for inputs that would overflow a UV,
1196or have leading zeros. Thus a single C<0> is accepted, but not C<00> nor
1197C<01>, C<002>, I<etc>.
1198
1199Background: C<atoi> has severe problems with illegal inputs, it cannot be
d62b8c6a 1200used for incremental parsing, and therefore should be avoided
5d4a52b5 1201C<atoi> and C<strtol> are also affected by locale settings, which can also be
d62b8c6a
JH
1202seen as a bug (global state controlled by user environment).
1203
238217e5
JK
1204=cut
1205
6313e544
JH
1206*/
1207
22ff3130
HS
1208bool
1209Perl_grok_atoUV(const char *pv, UV *valptr, const char** endptr)
6313e544
JH
1210{
1211 const char* s = pv;
1212 const char** eptr;
1213 const char* end2; /* Used in case endptr is NULL. */
22ff3130 1214 UV val = 0; /* The parsed value. */
6313e544 1215
22ff3130 1216 PERL_ARGS_ASSERT_GROK_ATOUV;
6313e544 1217
5d4a52b5
KW
1218 if (endptr) {
1219 eptr = endptr;
1220 }
1221 else {
1222 end2 = s + strlen(s);
1223 eptr = &end2;
1224 }
1225
1226 if ( *eptr <= s
1227 || ! isDIGIT(*s))
1228 {
1229 return FALSE;
1230 }
1231
97d95d46
KW
1232 /* Single-digit inputs are quite common. */
1233 val = *s++ - '0';
1234 if (s < *eptr && isDIGIT(*s)) {
1235 /* Fail on extra leading zeros. */
1236 if (val == 0)
1237 return FALSE;
1238 while (s < *eptr && isDIGIT(*s)) {
1239 /* This could be unrolled like in grok_number(), but
1240 * the expected uses of this are not speed-needy, and
1241 * unlikely to need full 64-bitness. */
1242 const U8 digit = *s++ - '0';
1243 if (val < uv_max_div_10 ||
1244 (val == uv_max_div_10 && digit <= uv_max_mod_10)) {
1245 val = val * 10 + digit;
1246 } else {
22ff3130 1247 return FALSE;
6313e544
JH
1248 }
1249 }
97d95d46
KW
1250 }
1251
5d4a52b5
KW
1252 if (endptr == NULL) {
1253 if (*s) {
1254 return FALSE; /* If endptr is NULL, no trailing non-digits allowed. */
1255 }
1256 }
1257 else {
1258 *endptr = s;
75feedba 1259 }
97d95d46 1260
22ff3130
HS
1261 *valptr = val;
1262 return TRUE;
6313e544
JH
1263}
1264
ce6f496d 1265#ifndef Perl_strtod
4801ca72 1266STATIC NV
98994639
HS
1267S_mulexp10(NV value, I32 exponent)
1268{
1269 NV result = 1.0;
1270 NV power = 10.0;
1271 bool negative = 0;
1272 I32 bit;
1273
1274 if (exponent == 0)
1275 return value;
659c4b96
DM
1276 if (value == 0)
1277 return (NV)0;
87032ba1 1278
24866caa 1279 /* On OpenVMS VAX we by default use the D_FLOAT double format,
67597c89 1280 * and that format does not have *easy* capabilities [1] for
19c1206d
KW
1281 * overflowing doubles 'silently' as IEEE fp does. We also need
1282 * to support G_FLOAT on both VAX and Alpha, and though the exponent
1283 * range is much larger than D_FLOAT it still doesn't do silent
1284 * overflow. Therefore we need to detect early whether we would
1285 * overflow (this is the behaviour of the native string-to-float
24866caa 1286 * conversion routines, and therefore of native applications, too).
67597c89 1287 *
24866caa
CB
1288 * [1] Trying to establish a condition handler to trap floating point
1289 * exceptions is not a good idea. */
87032ba1
JH
1290
1291 /* In UNICOS and in certain Cray models (such as T90) there is no
1292 * IEEE fp, and no way at all from C to catch fp overflows gracefully.
1293 * There is something you can do if you are willing to use some
1294 * inline assembler: the instruction is called DFI-- but that will
1295 * disable *all* floating point interrupts, a little bit too large
1296 * a hammer. Therefore we need to catch potential overflows before
1297 * it's too late. */
353813d9 1298
a7157111 1299#if ((defined(VMS) && !defined(_IEEE_FP)) || defined(_UNICOS) || defined(DOUBLE_IS_VAX_FLOAT)) && defined(NV_MAX_10_EXP)
353813d9 1300 STMT_START {
c4420975 1301 const NV exp_v = log10(value);
353813d9
HS
1302 if (exponent >= NV_MAX_10_EXP || exponent + exp_v >= NV_MAX_10_EXP)
1303 return NV_MAX;
1304 if (exponent < 0) {
1305 if (-(exponent + exp_v) >= NV_MAX_10_EXP)
1306 return 0.0;
1307 while (-exponent >= NV_MAX_10_EXP) {
1308 /* combination does not overflow, but 10^(-exponent) does */
1309 value /= 10;
1310 ++exponent;
1311 }
1312 }
1313 } STMT_END;
87032ba1
JH
1314#endif
1315
353813d9
HS
1316 if (exponent < 0) {
1317 negative = 1;
1318 exponent = -exponent;
b27804d8
DM
1319#ifdef NV_MAX_10_EXP
1320 /* for something like 1234 x 10^-309, the action of calculating
1321 * the intermediate value 10^309 then returning 1234 / (10^309)
1322 * will fail, since 10^309 becomes infinity. In this case try to
1323 * refactor it as 123 / (10^308) etc.
1324 */
1325 while (value && exponent > NV_MAX_10_EXP) {
1326 exponent--;
1327 value /= 10;
1328 }
48853916
JH
1329 if (value == 0.0)
1330 return value;
b27804d8 1331#endif
353813d9 1332 }
c62e754c
JH
1333#if defined(__osf__)
1334 /* Even with cc -ieee + ieee_set_fp_control(IEEE_TRAP_ENABLE_INV)
1335 * Tru64 fp behavior on inf/nan is somewhat broken. Another way
1336 * to do this would be ieee_set_fp_control(IEEE_TRAP_ENABLE_OVF)
1337 * but that breaks another set of infnan.t tests. */
1338# define FP_OVERFLOWS_TO_ZERO
1339#endif
98994639
HS
1340 for (bit = 1; exponent; bit <<= 1) {
1341 if (exponent & bit) {
1342 exponent ^= bit;
1343 result *= power;
c62e754c
JH
1344#ifdef FP_OVERFLOWS_TO_ZERO
1345 if (result == 0)
a7157111 1346# ifdef NV_INF
c62e754c 1347 return value < 0 ? -NV_INF : NV_INF;
a7157111
JH
1348# else
1349 return value < 0 ? -FLT_MAX : FLT_MAX;
1350# endif
c62e754c 1351#endif
236f0012 1352 /* Floating point exceptions are supposed to be turned off,
19c1206d 1353 * but if we're obviously done, don't risk another iteration.
236f0012
CB
1354 */
1355 if (exponent == 0) break;
98994639
HS
1356 }
1357 power *= power;
1358 }
1359 return negative ? value / result : value * result;
1360}
ce6f496d 1361#endif /* #ifndef Perl_strtod */
98994639 1362
ce6f496d 1363#ifdef Perl_strtod
b93d1309 1364# define ATOF(s, x) my_atof2(s, &x)
f7b64c80 1365#else
b93d1309 1366# define ATOF(s, x) Perl_atof2(s, x)
f7b64c80 1367#endif
b93d1309 1368
98994639
HS
1369NV
1370Perl_my_atof(pTHX_ const char* s)
1371{
f720c878
KW
1372 /* 's' must be NUL terminated */
1373
98994639 1374 NV x = 0.0;
9eda1ea6
KW
1375
1376 PERL_ARGS_ASSERT_MY_ATOF;
1377
b93d1309 1378#if ! defined(USE_LOCALE_NUMERIC)
9eda1ea6 1379
b93d1309 1380 ATOF(s, x);
9eda1ea6
KW
1381
1382#else
7918f24d 1383
a2287a13 1384 {
67d796ae
KW
1385 DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
1386 STORE_LC_NUMERIC_SET_TO_NEEDED();
fdf55d20
KW
1387 if (! (PL_numeric_radix_sv && IN_LC(LC_NUMERIC))) {
1388 ATOF(s,x);
1389 }
1390 else {
19c1206d 1391
e4850248
KW
1392 /* Look through the string for the first thing that looks like a
1393 * decimal point: either the value in the current locale or the
1394 * standard fallback of '.'. The one which appears earliest in the
1395 * input string is the one that we should have atof look for. Note
1396 * that we have to determine this beforehand because on some
1397 * systems, Perl_atof2 is just a wrapper around the system's atof.
1398 * */
1ae85f6c
KW
1399 const char * const standard_pos = strchr(s, '.');
1400 const char * const local_pos
1401 = strstr(s, SvPV_nolen(PL_numeric_radix_sv));
1402 const bool use_standard_radix
1403 = standard_pos && (!local_pos || standard_pos < local_pos);
78787052 1404
665873e9 1405 if (use_standard_radix) {
e4850248 1406 SET_NUMERIC_STANDARD();
665873e9
KW
1407 LOCK_LC_NUMERIC_STANDARD();
1408 }
78787052 1409
b93d1309 1410 ATOF(s,x);
78787052 1411
665873e9
KW
1412 if (use_standard_radix) {
1413 UNLOCK_LC_NUMERIC_STANDARD();
67d796ae 1414 SET_NUMERIC_UNDERLYING();
665873e9 1415 }
e4850248 1416 }
a2287a13
KW
1417 RESTORE_LC_NUMERIC();
1418 }
9eda1ea6 1419
98994639 1420#endif
9eda1ea6 1421
98994639
HS
1422 return x;
1423}
1424
a7157111 1425#if defined(NV_INF) || defined(NV_NAN)
3c81f0b3 1426
829757a4 1427static char*
5563f457 1428S_my_atof_infnan(pTHX_ const char* s, bool negative, const char* send, NV* value)
829757a4
JH
1429{
1430 const char *p0 = negative ? s - 1 : s;
1431 const char *p = p0;
7eff3d39 1432 const int infnan = grok_infnan(&p, send);
829757a4
JH
1433 if (infnan && p != p0) {
1434 /* If we can generate inf/nan directly, let's do so. */
1435#ifdef NV_INF
1436 if ((infnan & IS_NUMBER_INFINITY)) {
3823048b 1437 *value = (infnan & IS_NUMBER_NEG) ? -NV_INF: NV_INF;
829757a4
JH
1438 return (char*)p;
1439 }
1440#endif
1441#ifdef NV_NAN
1442 if ((infnan & IS_NUMBER_NAN)) {
3823048b 1443 *value = NV_NAN;
829757a4
JH
1444 return (char*)p;
1445 }
1446#endif
1447#ifdef Perl_strtod
68611e6f 1448 /* If still here, we didn't have either NV_INF or NV_NAN,
829757a4
JH
1449 * and can try falling back to native strtod/strtold.
1450 *
1451 * The native interface might not recognize all the possible
1452 * inf/nan strings Perl recognizes. What we can try
1453 * is to try faking the input. We will try inf/-inf/nan
1454 * as the most promising/portable input. */
1455 {
6d37e916 1456 const char* fake = "silence compiler warning";
829757a4
JH
1457 char* endp;
1458 NV nv;
a7157111 1459#ifdef NV_INF
829757a4
JH
1460 if ((infnan & IS_NUMBER_INFINITY)) {
1461 fake = ((infnan & IS_NUMBER_NEG)) ? "-inf" : "inf";
1462 }
a7157111
JH
1463#endif
1464#ifdef NV_NAN
1465 if ((infnan & IS_NUMBER_NAN)) {
829757a4
JH
1466 fake = "nan";
1467 }
a7157111 1468#endif
6d37e916 1469 assert(strNE(fake, "silence compiler warning"));
9ec8aea5 1470 nv = S_strtod(aTHX_ fake, &endp);
829757a4 1471 if (fake != endp) {
a7157111 1472#ifdef NV_INF
829757a4 1473 if ((infnan & IS_NUMBER_INFINITY)) {
a7157111 1474# ifdef Perl_isinf
829757a4
JH
1475 if (Perl_isinf(nv))
1476 *value = nv;
a7157111 1477# else
829757a4
JH
1478 /* last resort, may generate SIGFPE */
1479 *value = Perl_exp((NV)1e9);
1480 if ((infnan & IS_NUMBER_NEG))
1481 *value = -*value;
a7157111 1482# endif
829757a4
JH
1483 return (char*)p; /* p, not endp */
1484 }
a7157111
JH
1485#endif
1486#ifdef NV_NAN
1487 if ((infnan & IS_NUMBER_NAN)) {
1488# ifdef Perl_isnan
829757a4
JH
1489 if (Perl_isnan(nv))
1490 *value = nv;
a7157111 1491# else
829757a4
JH
1492 /* last resort, may generate SIGFPE */
1493 *value = Perl_log((NV)-1.0);
a7157111 1494# endif
829757a4 1495 return (char*)p; /* p, not endp */
a7157111 1496#endif
829757a4
JH
1497 }
1498 }
1499 }
1500#endif /* #ifdef Perl_strtod */
1501 }
1502 return NULL;
1503}
1504
a7157111
JH
1505#endif /* if defined(NV_INF) || defined(NV_NAN) */
1506
98994639
HS
1507char*
1508Perl_my_atof2(pTHX_ const char* orig, NV* value)
1509{
6928bedc
KW
1510 PERL_ARGS_ASSERT_MY_ATOF2;
1511 return my_atof3(orig, value, 0);
1512}
1513
1514char*
16411967 1515Perl_my_atof3(pTHX_ const char* orig, NV* value, const STRLEN len)
6928bedc 1516{
e1ec3a88 1517 const char* s = orig;
a4eca1d4 1518 NV result[3] = {0.0, 0.0, 0.0};
ce6f496d 1519#if defined(USE_PERL_ATOF) || defined(Perl_strtod)
6928bedc
KW
1520 const char* send = s + ((len != 0)
1521 ? len
1522 : strlen(orig)); /* one past the last */
a4eca1d4
JH
1523 bool negative = 0;
1524#endif
ce6f496d 1525#if defined(USE_PERL_ATOF) && !defined(Perl_strtod)
a4eca1d4 1526 UV accumulator[2] = {0,0}; /* before/after dp */
8194bf88 1527 bool seen_digit = 0;
20f6aaab
AS
1528 I32 exp_adjust[2] = {0,0};
1529 I32 exp_acc[2] = {-1, -1};
1530 /* the current exponent adjust for the accumulators */
98994639 1531 I32 exponent = 0;
8194bf88 1532 I32 seen_dp = 0;
20f6aaab
AS
1533 I32 digit = 0;
1534 I32 old_digit = 0;
8194bf88 1535 I32 sig_digits = 0; /* noof significant digits seen so far */
a4eca1d4 1536#endif
8194bf88 1537
ce6f496d 1538#if defined(USE_PERL_ATOF) || defined(Perl_strtod)
6928bedc 1539 PERL_ARGS_ASSERT_MY_ATOF3;
7918f24d 1540
a4eca1d4 1541 /* leading whitespace */
6928bedc 1542 while (s < send && isSPACE(*s))
a4eca1d4
JH
1543 ++s;
1544
1545 /* sign */
1546 switch (*s) {
1547 case '-':
1548 negative = 1;
1549 /* FALLTHROUGH */
1550 case '+':
1551 ++s;
1552 }
1553#endif
1554
ce6f496d 1555#ifdef Perl_strtod
a4eca1d4
JH
1556 {
1557 char* endp;
d94e901a
KW
1558 char* copy = NULL;
1559
adc55e02 1560 if ((endp = S_my_atof_infnan(aTHX_ s, negative, send, value)))
a4eca1d4 1561 return endp;
d94e901a 1562
14d26b44
TC
1563 /* strtold() accepts 0x-prefixed hex and in POSIX implementations,
1564 0b-prefixed binary numbers, which is backward incompatible
1565 */
e56dfd96 1566 if ((len == 0 || len - (s-orig) >= 2) && *s == '0' &&
14d26b44
TC
1567 (isALPHA_FOLD_EQ(s[1], 'x') || isALPHA_FOLD_EQ(s[1], 'b'))) {
1568 *value = 0;
1569 return (char *)s+1;
1570 }
1571
d94e901a
KW
1572 /* If the length is passed in, the input string isn't NUL-terminated,
1573 * and in it turns out the function below assumes it is; therefore we
1574 * create a copy and NUL-terminate that */
1575 if (len) {
1576 Newx(copy, len + 1, char);
1577 Copy(orig, copy, len, char);
1578 copy[len] = '\0';
1579 s = copy + (s - orig);
1580 }
1581
9ec8aea5 1582 result[2] = S_strtod(aTHX_ s, &endp);
d94e901a
KW
1583
1584 /* If we created a copy, 'endp' is in terms of that. Convert back to
1585 * the original */
1586 if (copy) {
aac39b03 1587 s = (s - copy) + (char *) orig;
d94e901a
KW
1588 endp = (endp - copy) + (char *) orig;
1589 Safefree(copy);
1590 }
1591
a4eca1d4
JH
1592 if (s != endp) {
1593 *value = negative ? -result[2] : result[2];
1594 return endp;
1595 }
1596 return NULL;
1597 }
1598#elif defined(USE_PERL_ATOF)
1599
8194bf88
DM
1600/* There is no point in processing more significant digits
1601 * than the NV can hold. Note that NV_DIG is a lower-bound value,
1602 * while we need an upper-bound value. We add 2 to account for this;
1603 * since it will have been conservative on both the first and last digit.
1604 * For example a 32-bit mantissa with an exponent of 4 would have
1605 * exact values in the set
1606 * 4
1607 * 8
1608 * ..
1609 * 17179869172
1610 * 17179869176
1611 * 17179869180
1612 *
1613 * where for the purposes of calculating NV_DIG we would have to discount
1614 * both the first and last digit, since neither can hold all values from
1615 * 0..9; but for calculating the value we must examine those two digits.
1616 */
ffa277e5
EAS
1617#ifdef MAX_SIG_DIG_PLUS
1618 /* It is not necessarily the case that adding 2 to NV_DIG gets all the
1619 possible digits in a NV, especially if NVs are not IEEE compliant
1620 (e.g., long doubles on IRIX) - Allen <allens@cpan.org> */
1621# define MAX_SIG_DIGITS (NV_DIG+MAX_SIG_DIG_PLUS)
1622#else
1623# define MAX_SIG_DIGITS (NV_DIG+2)
1624#endif
8194bf88
DM
1625
1626/* the max number we can accumulate in a UV, and still safely do 10*N+9 */
1627#define MAX_ACCUMULATE ( (UV) ((UV_MAX - 9)/10))
98994639 1628
a5dc2484 1629#if defined(NV_INF) || defined(NV_NAN)
ae776a2c 1630 {
7eff3d39 1631 char* endp;
5563f457 1632 if ((endp = S_my_atof_infnan(aTHX_ s, negative, send, value)))
7eff3d39 1633 return endp;
ae776a2c 1634 }
a5dc2484 1635#endif
2b54f59f 1636
8194bf88
DM
1637 /* we accumulate digits into an integer; when this becomes too
1638 * large, we add the total to NV and start again */
98994639 1639
6928bedc 1640 while (s < send) {
8194bf88
DM
1641 if (isDIGIT(*s)) {
1642 seen_digit = 1;
20f6aaab 1643 old_digit = digit;
8194bf88 1644 digit = *s++ - '0';
20f6aaab
AS
1645 if (seen_dp)
1646 exp_adjust[1]++;
98994639 1647
8194bf88
DM
1648 /* don't start counting until we see the first significant
1649 * digit, eg the 5 in 0.00005... */
1650 if (!sig_digits && digit == 0)
1651 continue;
1652
1653 if (++sig_digits > MAX_SIG_DIGITS) {
98994639 1654 /* limits of precision reached */
20f6aaab
AS
1655 if (digit > 5) {
1656 ++accumulator[seen_dp];
1657 } else if (digit == 5) {
1658 if (old_digit % 2) { /* round to even - Allen */
1659 ++accumulator[seen_dp];
1660 }
1661 }
1662 if (seen_dp) {
1663 exp_adjust[1]--;
1664 } else {
1665 exp_adjust[0]++;
1666 }
8194bf88 1667 /* skip remaining digits */
6928bedc 1668 while (s < send && isDIGIT(*s)) {
98994639 1669 ++s;
20f6aaab
AS
1670 if (! seen_dp) {
1671 exp_adjust[0]++;
1672 }
98994639
HS
1673 }
1674 /* warn of loss of precision? */
98994639 1675 }
8194bf88 1676 else {
20f6aaab 1677 if (accumulator[seen_dp] > MAX_ACCUMULATE) {
8194bf88 1678 /* add accumulator to result and start again */
20f6aaab
AS
1679 result[seen_dp] = S_mulexp10(result[seen_dp],
1680 exp_acc[seen_dp])
1681 + (NV)accumulator[seen_dp];
1682 accumulator[seen_dp] = 0;
1683 exp_acc[seen_dp] = 0;
98994639 1684 }
20f6aaab
AS
1685 accumulator[seen_dp] = accumulator[seen_dp] * 10 + digit;
1686 ++exp_acc[seen_dp];
98994639 1687 }
8194bf88 1688 }
e1ec3a88 1689 else if (!seen_dp && GROK_NUMERIC_RADIX(&s, send)) {
8194bf88 1690 seen_dp = 1;
20f6aaab 1691 if (sig_digits > MAX_SIG_DIGITS) {
6928bedc 1692 while (s < send && isDIGIT(*s)) {
20f6aaab 1693 ++s;
9604fbf0 1694 }
20f6aaab
AS
1695 break;
1696 }
8194bf88
DM
1697 }
1698 else {
1699 break;
98994639
HS
1700 }
1701 }
1702
20f6aaab
AS
1703 result[0] = S_mulexp10(result[0], exp_acc[0]) + (NV)accumulator[0];
1704 if (seen_dp) {
1705 result[1] = S_mulexp10(result[1], exp_acc[1]) + (NV)accumulator[1];
1706 }
98994639 1707
6928bedc 1708 if (s < send && seen_digit && (isALPHA_FOLD_EQ(*s, 'e'))) {
98994639
HS
1709 bool expnegative = 0;
1710
1711 ++s;
1712 switch (*s) {
1713 case '-':
1714 expnegative = 1;
924ba076 1715 /* FALLTHROUGH */
98994639
HS
1716 case '+':
1717 ++s;
1718 }
6928bedc 1719 while (s < send && isDIGIT(*s))
98994639
HS
1720 exponent = exponent * 10 + (*s++ - '0');
1721 if (expnegative)
1722 exponent = -exponent;
1723 }
1724
1725 /* now apply the exponent */
20f6aaab
AS
1726
1727 if (seen_dp) {
1728 result[2] = S_mulexp10(result[0],exponent+exp_adjust[0])
1729 + S_mulexp10(result[1],exponent-exp_adjust[1]);
1730 } else {
1731 result[2] = S_mulexp10(result[0],exponent+exp_adjust[0]);
1732 }
98994639
HS
1733
1734 /* now apply the sign */
1735 if (negative)
20f6aaab 1736 result[2] = -result[2];
a36244b7 1737#endif /* USE_PERL_ATOF */
20f6aaab 1738 *value = result[2];
73d840c0 1739 return (char *)s;
98994639
HS
1740}
1741
5d34af89 1742/*
3d9d9213 1743=for apidoc isinfnan
5d34af89 1744
796b6530
KW
1745C<Perl_isinfnan()> is utility function that returns true if the NV
1746argument is either an infinity or a C<NaN>, false otherwise. To test
1747in more detail, use C<Perl_isinf()> and C<Perl_isnan()>.
5d34af89 1748
68611e6f
JH
1749This is also the logical inverse of Perl_isfinite().
1750
5d34af89
JH
1751=cut
1752*/
1cd88304
JH
1753bool
1754Perl_isinfnan(NV nv)
1755{
a5dc2484 1756 PERL_UNUSED_ARG(nv);
1cd88304
JH
1757#ifdef Perl_isinf
1758 if (Perl_isinf(nv))
1759 return TRUE;
1760#endif
1761#ifdef Perl_isnan
1762 if (Perl_isnan(nv))
1763 return TRUE;
1764#endif
1765 return FALSE;
1766}
1767
354b74ae 1768/*
af147c81 1769=for apidoc isinfnansv
354b74ae 1770
796b6530 1771Checks whether the argument would be either an infinity or C<NaN> when used
354b74ae 1772as a number, but is careful not to trigger non-numeric or uninitialized
796b6530 1773warnings. it assumes the caller has done C<SvGETMAGIC(sv)> already.
354b74ae
FC
1774
1775=cut
1776*/
1777
1778bool
1779Perl_isinfnansv(pTHX_ SV *sv)
1780{
1781 PERL_ARGS_ASSERT_ISINFNANSV;
1782 if (!SvOK(sv))
1783 return FALSE;
1784 if (SvNOKp(sv))
1785 return Perl_isinfnan(SvNVX(sv));
1786 if (SvIOKp(sv))
1787 return FALSE;
1788 {
1789 STRLEN len;
1790 const char *s = SvPV_nomg_const(sv, len);
3823048b 1791 return cBOOL(grok_infnan(&s, s+len));
354b74ae
FC
1792 }
1793}
1794
d67dac15 1795#ifndef HAS_MODFL
68611e6f
JH
1796/* C99 has truncl, pre-C99 Solaris had aintl. We can use either with
1797 * copysignl to emulate modfl, which is in some platforms missing or
1798 * broken. */
d67dac15
JH
1799# if defined(HAS_TRUNCL) && defined(HAS_COPYSIGNL)
1800long double
1801Perl_my_modfl(long double x, long double *ip)
1802{
68611e6f
JH
1803 *ip = truncl(x);
1804 return (x == *ip ? copysignl(0.0L, x) : x - *ip);
d67dac15
JH
1805}
1806# elif defined(HAS_AINTL) && defined(HAS_COPYSIGNL)
55954f19
JH
1807long double
1808Perl_my_modfl(long double x, long double *ip)
1809{
68611e6f
JH
1810 *ip = aintl(x);
1811 return (x == *ip ? copysignl(0.0L, x) : x - *ip);
55954f19 1812}
d67dac15 1813# endif
55954f19
JH
1814#endif
1815
7b9b7dff 1816/* Similarly, with ilogbl and scalbnl we can emulate frexpl. */
55954f19
JH
1817#if ! defined(HAS_FREXPL) && defined(HAS_ILOGBL) && defined(HAS_SCALBNL)
1818long double
1819Perl_my_frexpl(long double x, int *e) {
68611e6f
JH
1820 *e = x == 0.0L ? 0 : ilogbl(x) + 1;
1821 return (scalbnl(x, -*e));
55954f19
JH
1822}
1823#endif
66610fdd
RGS
1824
1825/*
ed140128
AD
1826=for apidoc Perl_signbit
1827
1828Return a non-zero integer if the sign bit on an NV is set, and 0 if
19c1206d 1829it is not.
ed140128 1830
796b6530
KW
1831If F<Configure> detects this system has a C<signbit()> that will work with
1832our NVs, then we just use it via the C<#define> in F<perl.h>. Otherwise,
8b7fad81 1833fall back on this implementation. The main use of this function
796b6530 1834is catching C<-0.0>.
ed140128 1835
796b6530
KW
1836C<Configure> notes: This function is called C<'Perl_signbit'> instead of a
1837plain C<'signbit'> because it is easy to imagine a system having a C<signbit()>
ed140128 1838function or macro that doesn't happen to work with our particular choice
796b6530 1839of NVs. We shouldn't just re-C<#define> C<signbit> as C<Perl_signbit> and expect
ed140128 1840the standard system headers to be happy. Also, this is a no-context
796b6530
KW
1841function (no C<pTHX_>) because C<Perl_signbit()> is usually re-C<#defined> in
1842F<perl.h> as a simple macro call to the system's C<signbit()>.
1843Users should just always call C<Perl_signbit()>.
ed140128
AD
1844
1845=cut
1846*/
1847#if !defined(HAS_SIGNBIT)
1848int
1849Perl_signbit(NV x) {
8b7fad81 1850# ifdef Perl_fp_class_nzero
406d5545
JH
1851 return Perl_fp_class_nzero(x);
1852 /* Try finding the high byte, and assume it's highest bit
1853 * is the sign. This assumption is probably wrong somewhere. */
572cd850
JH
1854# elif defined(USE_LONG_DOUBLE) && LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_LITTLE_ENDIAN
1855 return (((unsigned char *)&x)[9] & 0x80);
1856# elif defined(NV_LITTLE_ENDIAN)
1857 /* Note that NVSIZE is sizeof(NV), which would make the below be
1858 * wrong if the end bytes are unused, which happens with the x86
1859 * 80-bit long doubles, which is why take care of that above. */
1860 return (((unsigned char *)&x)[NVSIZE - 1] & 0x80);
1861# elif defined(NV_BIG_ENDIAN)
1862 return (((unsigned char *)&x)[0] & 0x80);
1863# else
406d5545 1864 /* This last resort fallback is wrong for the negative zero. */
3585840c 1865 return (x < 0.0) ? 1 : 0;
572cd850 1866# endif
ed140128
AD
1867}
1868#endif
1869
1870/*
14d04a33 1871 * ex: set ts=8 sts=4 sw=4 et:
37442d52 1872 */